Import Upstream version 2a6upstream/2a6

1 files changed, 362 insertions, 0 deletions

diff --git a/mbe.scm b/mbe.scm
new file mode 100644
index 0000000..e48e1f1
--- /dev/null
+++ b/mbe.scm
@@ -0,0 +1,362 @@
+;;;; "mbe.scm" "Macro by Example" (Eugene Kohlbecker, r4rs)
+;;; From: Dorai Sitaram, dorai@cs.rice.edu, 1991, revised Sept. 3, 1992,
+;
+;Permission to copy this software, to redistribute it, and to use it
+;for any purpose is granted, subject to the following restrictions and
+;understandings.
+;
+;1.  Any copy made of this software must include this copyright notice
+;in full.
+;
+;2.  I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3.  In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+;;; revised Dec. 6, 1993 to r4rs syntax (if not semantics).
+;;; revised Mar. 2 1994 for SLIB (jaffer@ai.mit.edu).
+
+;;; A vanilla implementation of Macro-by-Example (Eugene
+;;; Kohlbecker, r4rs).  This file requires defmacro.
+
+(require 'common-list-functions)	;nconc, some, every
+;(require 'rev2-procedures)		;append! alternate for nconc
+(require 'rev4-optional-procedures)	;list-tail
+(require 'defmacroexpand)
+
+;;; A vanilla implementation of a hygiene filter for define-syntax
+
+;(define hyg:tag-generic
+;  (lambda (e kk tmps) e))
+
+;;; if you don't want the hygiene filter, comment out the following
+;;; s-exp and uncomment the previous one.
+
+(define hyg:tag-generic
+  (lambda (e kk tmps)
+    (if (pair? e)
+	(let ((a (car e)))
+	  (case a
+	    ((quote) `(quote ,(hyg:tag-vanilla (cadr e) kk tmps)))
+	    ((if begin)
+	     `(,a ,@(map (lambda (e1) (hyg:tag-generic e1 kk tmps))
+			 (cdr e))))
+	    ((set! define)
+	     `(,a ,(hyg:tag-vanilla (cadr e) kk tmps)
+		  ,@(map (lambda (e1) (hyg:tag-generic e1 kk tmps))
+			 (cddr e))))
+	    ((lambda) (hyg:tag-lambda (cdr e) kk tmps))
+	    ((letrec) (hyg:tag-letrec (cdr e) kk tmps))
+	    ((let) (hyg:tag-let (cdr e) kk tmps))
+	    ((let*) (hyg:tag-let-star (cdr e) kk tmps))
+	    ((do) (hyg:tag-do (cdr e) kk tmps))
+	    ((case)
+	     `(case ,(hyg:tag-generic (cadr e) kk tmps)
+		,@(map
+		   (lambda (cl)
+		     `(,(hyg:tag-vanilla (car cl) kk tmps)
+		       ,@(map
+			  (lambda (e1)
+			    (hyg:tag-generic e1 kk tmps))
+			  (cdr cl))))
+		   (cddr e))))
+	    ((cond)
+	     `(cond ,@(map
+		       (lambda (cl)
+			 (map (lambda (e1)
+				(hyg:tag-generic e1 kk tmps))
+			      cl))
+		       (cdr e))))
+	    (else (map (lambda (e1)
+			 (hyg:tag-generic e1 kk tmps))
+		       e))))
+	(hyg:tag-vanilla e kk tmps))))
+
+(define hyg:tag-vanilla
+  (lambda (e kk tmps)
+    (cond ((symbol? e)
+	   (cond ((memq e kk) e)
+		 ((assq e tmps) => cdr)
+		 (else e)))
+	  ((pair? e)
+	   (cons (hyg:tag-vanilla (car e) kk tmps)
+		 (hyg:tag-vanilla (cdr e) kk tmps)))
+	  (else e))))
+
+(define hyg:tag-lambda
+  (lambda (e kk tmps)
+    (let* ((bvv (car e))
+	   (tmps2 (append
+		   (map (lambda (v) (cons v (gentemp)))
+			(hyg:flatten bvv))
+		   tmps)))
+      `(lambda
+	   ,(hyg:tag-vanilla bvv kk tmps2)
+	 ,@(map
+	    (lambda (e1)
+	      (hyg:tag-generic e1 kk tmps2))
+	    (cdr e))))))
+
+(define hyg:flatten
+  (lambda (e)
+    (let loop ((e e) (r '()))
+      (cond ((pair? e) (loop (car e)
+			     (loop (cdr e) r)))
+	    ((null? e) r)
+	    (else (cons e r))))))
+
+(define hyg:tag-letrec
+  (lambda (e kk tmps)
+    (let* ((varvals (car e))
+	   (tmps2 (append
+		   (map (lambda (v) (cons v (gentemp)))
+			(map car varvals))
+		   tmps)))
+      `(letrec ,(map
+		 (lambda (varval)
+		   `(,(hyg:tag-vanilla (car varval)
+				       kk tmps2)
+		     ,(hyg:tag-generic (cadr varval)
+				       kk tmps2)))
+		 varvals)
+	 ,@(map (lambda (e1)
+		  (hyg:tag-generic e1 kk tmps2))
+		(cdr e))))))
+
+(define hyg:tag-let
+  (lambda (e kk tmps)
+    (let* ((tt (if (symbol? (car e)) (cons (car e) (gentemp)) '()))
+	   (e (if (null? tt) e (cdr e)))
+	   (tmps (if (null? tt) tmps (append (list tt) tmps))))
+      (let* ((varvals (car e))
+	     (tmps2 (append (map (lambda (v) (cons v (gentemp)))
+				 (map car varvals))
+			    tmps)))
+	`(let
+	   ,@(if (null? tt) '() `(,(hyg:tag-vanilla (car tt) 
+						    kk
+						    tmps)))
+	   ,(let loop ((varvals varvals)
+		       (i (length varvals)))
+	      (if (null? varvals) '()
+		  (let ((varval (car varvals))
+			(tmps3 (list-tail tmps2 i)))
+		    (cons `(,(hyg:tag-vanilla (car varval)
+					      kk tmps2)
+			    ,(hyg:tag-generic (cadr varval)
+					      kk tmps3))
+			  (loop (cdr varvals) (- i 1))))))
+	   ,@(map
+	      (lambda (e1)
+		(hyg:tag-generic e1 kk tmps2))
+	      (cdr e)))))))
+
+(define hyg:tag-do
+  (lambda (e kk tmps)
+    (let* ((varinistps (car e))
+	   (tmps2 (append (map (lambda (v) (cons v (gentemp)))
+			       (map car varinistps))
+			  tmps)))
+      `(do
+	   ,(let loop ((varinistps varinistps)
+		       (i (length varinistps)))
+	      (if (null? varinistps) '()
+		  (let ((varinistp (car varinistps))
+			(tmps3 (list-tail tmps2 i)))
+		    (cons `(,(hyg:tag-vanilla (car varinistp)
+					      kk tmps2)
+			    ,(hyg:tag-generic (cadr varinistp)
+					      kk tmps3)
+			    ,@(hyg:tag-generic (cddr varinistp)
+					       kk tmps2))
+			  (loop (cdr varinistps) (- i 1))))))
+	   ,(map (lambda (e1)
+		   (hyg:tag-generic e1 kk tmps2)) (cadr e))
+	 ,@(map
+	    (lambda (e1)
+	      (hyg:tag-generic e1 kk tmps2))
+	    (cddr e))))))
+
+(define hyg:tag-let-star
+  (lambda (e kk tmps)
+    (let* ((varvals (car e))
+	   (tmps2 (append (reverse (map (lambda (v) (cons v (gentemp)))
+					(map car varvals)))
+			  tmps)))
+      `(let*
+	   ,(let loop ((varvals varvals)
+		       (i (- (length varvals) 1)))
+	      (if (null? varvals) '()
+		  (let ((varval (car varvals))
+			(tmps3 (list-tail tmps2 i)))
+		    (cons `(,(hyg:tag-vanilla (car varval)
+					      kk tmps3)
+			    ,(hyg:tag-generic (cadr varval)
+					      kk (cdr tmps3)))
+			  (loop (cdr varvals) (- i 1))))))
+	 ,@(map
+	    (lambda (e1)
+	      (hyg:tag-generic e1 kk tmps2))
+	    (cdr e))))))
+
+;;;; End of hygiene filter.
+
+;;; finds the leftmost index of list l where something equal to x
+;;; occurs
+(define mbe:position
+  (lambda (x l)
+    (let loop ((l l) (i 0))
+      (cond ((not (pair? l)) #f)
+	    ((equal? (car l) x) i)
+	    (else (loop (cdr l) (+ i 1)))))))
+
+;;; tests if expression e matches pattern p where k is the list of
+;;; keywords
+(define mbe:matches-pattern?
+  (lambda (p e k)
+    (cond ((mbe:ellipsis? p)
+	   (and (or (null? e) (pair? e))
+		(let* ((p-head (car p))
+		       (p-tail (cddr p))
+		       (e-head=e-tail (mbe:split-at-ellipsis e p-tail)))
+		  (and e-head=e-tail
+		       (let ((e-head (car e-head=e-tail))
+			     (e-tail (cdr e-head=e-tail)))
+			 (and (comlist:every
+			       (lambda (x) (mbe:matches-pattern? p-head x k))
+			       e-head)
+			      (mbe:matches-pattern? p-tail e-tail k)))))))
+	  ((pair? p)
+	   (and (pair? e)
+		(mbe:matches-pattern? (car p) (car e) k)
+		(mbe:matches-pattern? (cdr p) (cdr e) k)))
+	  ((symbol? p) (if (memq p k) (eq? p e) #t))
+	  (else (equal? p e)))))
+
+;;; gets the bindings of pattern variables of pattern p for
+;;; expression e;
+;;; k is the list of keywords
+(define mbe:get-bindings
+  (lambda (p e k)
+    (cond ((mbe:ellipsis? p)
+	   (let* ((p-head (car p))
+		  (p-tail (cddr p))
+		  (e-head=e-tail (mbe:split-at-ellipsis e p-tail))
+		  (e-head (car e-head=e-tail))
+		  (e-tail (cdr e-head=e-tail)))
+	     (cons (cons (mbe:get-ellipsis-nestings p-head k)
+		     (map (lambda (x) (mbe:get-bindings p-head x k))
+			  e-head))
+	       (mbe:get-bindings p-tail e-tail k))))
+	  ((pair? p)
+	   (append (mbe:get-bindings (car p) (car e) k)
+	     (mbe:get-bindings (cdr p) (cdr e) k)))
+	  ((symbol? p)
+	   (if (memq p k) '() (list (cons p e))))
+	  (else '()))))
+
+;;; expands pattern p using environment r;
+;;; k is the list of keywords
+(define mbe:expand-pattern
+  (lambda (p r k)
+    (cond ((mbe:ellipsis? p)
+	   (append (let* ((p-head (car p))
+			  (nestings (mbe:get-ellipsis-nestings p-head k))
+			  (rr (mbe:ellipsis-sub-envs nestings r)))
+		     (map (lambda (r1)
+			    (mbe:expand-pattern p-head (append r1 r) k))
+			  rr))
+	     (mbe:expand-pattern (cddr p) r k)))
+	  ((pair? p)
+	   (cons (mbe:expand-pattern (car p) r k)
+	     (mbe:expand-pattern (cdr p) r k)))
+	  ((symbol? p)
+	   (if (memq p k) p
+	     (let ((x (assq p r)))
+	       (if x (cdr x) p))))
+	  (else p))))
+
+;;; returns a list that nests a pattern variable as deeply as it
+;;; is ellipsed
+(define mbe:get-ellipsis-nestings
+  (lambda (p k)
+    (let sub ((p p))
+      (cond ((mbe:ellipsis? p) (cons (sub (car p)) (sub (cddr p))))
+	    ((pair? p) (append (sub (car p)) (sub (cdr p))))
+	    ((symbol? p) (if (memq p k) '() (list p)))
+	    (else '())))))
+
+;;; finds the subenvironments in r corresponding to the ellipsed
+;;; variables in nestings
+(define mbe:ellipsis-sub-envs
+  (lambda (nestings r)
+    (comlist:some (lambda (c)
+		    (if (mbe:contained-in? nestings (car c)) (cdr c) #f))
+		  r)))
+
+;;; checks if nestings v and y have an intersection
+(define mbe:contained-in?
+  (lambda (v y)
+    (if (or (symbol? v) (symbol? y)) (eq? v y)
+	(comlist:some (lambda (v_i)
+			(comlist:some (lambda (y_j)
+					(mbe:contained-in? v_i y_j))
+				      y))
+		      v))))
+
+;;; split expression e so that its second half matches with
+;;; pattern p-tail
+(define mbe:split-at-ellipsis
+  (lambda (e p-tail)
+    (if (null? p-tail) (cons e '())
+      (let ((i (mbe:position (car p-tail) e)))
+	(if i (cons (butlast e (- (length e) i))
+		    (list-tail e i))
+	    (slib:error 'mbe:split-at-ellipsis 'bad-arg))))))
+
+;;; tests if x is an ellipsing pattern, i.e., of the form
+;;; (blah ... . blah2)
+(define mbe:ellipsis?
+  (lambda (x)
+    (and (pair? x) (pair? (cdr x)) (eq? (cadr x) '...))))
+
+;define-syntax
+
+(defmacro define-syntax (macro-name syn-rules)
+  (if (or (not (pair? syn-rules))
+	  (not (eq? (car syn-rules) 'syntax-rules)))
+      (slib:error 'define-syntax 'not-an-r4rs-high-level-macro
+	     macro-name syn-rules)
+      (let ((keywords (cons macro-name (cadr syn-rules)))
+	    (clauses (cddr syn-rules)))
+	`(defmacro ,macro-name macro-arg
+	   (let ((macro-arg (cons ',macro-name macro-arg))
+		 (keywords ',keywords))
+	     (cond ,@(map
+		      (lambda (clause)
+			(let ((in-pattern (car clause))
+			      (out-pattern (cadr clause)))
+			  `((mbe:matches-pattern? ',in-pattern macro-arg
+						  keywords)
+			    (hyg:tag-generic
+			     (mbe:expand-pattern
+			      ',out-pattern
+			      (mbe:get-bindings ',in-pattern macro-arg
+						keywords)
+			      keywords)
+			     (nconc
+			      (hyg:flatten ',in-pattern)
+			      keywords)
+			     '()))))
+		      clauses)
+		   (else (slib:error ',macro-name 'no-matching-clause
+				',clauses))))))))
+
+(define macro:eval slib:eval)
+(define macro:load slib:load)
+(provide 'macro)
+;eof