Import Upstream version 5b3upstream/5b3

1 files changed, 292 insertions, 0 deletions

diff --git a/Macro.scm b/Macro.scm
new file mode 100644
index 0000000..f053b9c
--- /dev/null
+++ b/Macro.scm
@@ -0,0 +1,292 @@
+;; Support for R4RS macros.
+;;
+;; As in SYNTAX-CASE, the identifier ... may be quoted in a 
+;; SYNTAX-RULES pattern or template as (... ...).
+;;
+;; THE-MACRO may be used to define macros, eg
+;; (define-syntax foo (the-macro and))
+;; defines the syntactic keyword FOO to have the same transformer 
+;; as the macro AND.
+
+(require 'rev2-procedures) ;append!
+(require 'record)
+
+(define macro:compile-syntax-rules
+  ;; We keep local copies of these standard special forms, otherwise, 
+  ;; redefining them before they are memoized below can lead to 
+  ;; infinite recursion.
+  (@let-syntax ((lambda (the-macro lambda))
+		(let (the-macro let))
+		(cond (the-macro cond))
+		(if (the-macro if))
+		(and (the-macro and))
+		(or (the-macro or)))
+    (let ((var-rtd (make-record-type '? '(name rank)))
+	  (e-pat-rtd (make-record-type '... '(pattern vars))))
+      
+      (define pattern-variable (record-constructor var-rtd '(name rank)))
+      (define pattern-variable? (record-predicate var-rtd))
+      (define pattern-variable->name
+	(let ((acc (record-accessor var-rtd 'name)))
+	  (lambda (x) (identifier->symbol (acc x)))))
+      (define pattern-variable->rank (record-accessor var-rtd 'rank))
+
+      ;; An ellipsis-pattern is used both for ellipses in patterns and
+      ;; ellipses in templates.  In a pattern, VARS is the list of variables
+      ;; bound by the ellipsis pattern.  In a template, VARS is the list of
+      ;; variables opened by the ellipsis template.
+
+      (define ellipsis-pattern (record-constructor e-pat-rtd '(pattern vars)))
+      (define ellipsis-pattern? (record-predicate e-pat-rtd))
+      (define ellipsis-pattern->pattern (record-accessor e-pat-rtd 'pattern))
+      (define ellipsis-pattern->vars (record-accessor e-pat-rtd 'vars))
+
+      (define (append2 x y)
+	(if (null? y) x
+	    (append x y)))
+      
+      (define ellipsis?
+	(let (($... (renamed-identifier '... #f)))
+	  (lambda (x env)
+	    (and
+	     (identifier? x)
+	     (identifier-equal? x $... env)))))
+
+      ;; Yeah, it's quadratically slow.
+      (define (duplicates? vars)
+	(if (null? vars)
+	    #f
+	    (if (memq (car vars) (cdr vars))
+		(car vars)
+		(duplicates? (cdr vars)))))
+
+      (define (compile-pattern literals rule env-def)
+	(let recur ((pat (cdar rule))
+		    (vars '())
+		    (rank 0)
+		    (k (lambda (compiled vars)
+			 (let ((dup (duplicates? (map car vars))))
+			   (if dup
+			       (error 
+				"syntax-rules: duplicate pattern variable:"
+				dup " in rule " rule)))
+			 (cons compiled
+			       (rewrite-template
+				(cadr rule) vars env-def)))))
+	  (cond ((null? pat)
+		 (k pat vars))
+		((identifier? pat)
+		 (let ((lit (memq pat literals)))
+		   (if lit
+		       (k pat vars)
+		       (let ((var (pattern-variable pat rank)))
+			 (k var (cons (cons pat var) vars))))))
+		((pair? pat)
+		 (if (and (pair? (cdr pat))
+			  (ellipsis? (cadr pat) env-def)
+			  (or (null? (cddr pat))
+			      (error "bad ellipsis:" pat)))
+		     (if (ellipsis? (car pat) env-def)
+			 (recur (car pat) vars rank k)
+			 (recur (car pat) '() (+ rank 1)
+				(lambda (comp1 vars1)
+				  (k (list
+				      (ellipsis-pattern comp1 (map cdr vars1)))
+				     (append2 vars1 vars)))))
+		     (recur (car pat) '() rank
+			    (lambda (comp1 vars1)
+			      (recur (cdr pat) vars rank
+				     (lambda (comp2 vars2)
+				       (k (cons comp1 comp2)
+					  (append2 vars1 vars2)))))))))))
+      
+      (define (rewrite-template template vars env-def)
+	(let recur ((tmpl template)
+		    (rank 0)
+		    (inserted '())
+		    (k (lambda (compiled inserted opened)
+			 (list inserted compiled))))
+	  (cond ((null? tmpl)
+		 (k tmpl '() '()))
+		((identifier? tmpl)
+		 (let ((v (assq tmpl vars)))
+		   (if v
+		       (cond ((= rank (pattern-variable->rank (cdr v)))
+			      (k (cdr v) '() (list (cdr v))))
+			     ((> rank (pattern-variable->rank (cdr v)))
+			      (k (cdr v) '() '()))
+			     (else
+			      (error "pattern variable rank mismatch:" tmpl
+				     " in " template)))
+		       (k tmpl (list tmpl) '()))))
+		((pair? tmpl)
+		 (if (and (pair? (cdr tmpl))
+			  (ellipsis? (cadr tmpl) env-def))
+		     (if (and (ellipsis? (car tmpl) env-def)
+			      (or (null? (cddr tmpl))
+				  (error "bad ellipsis:" tmpl)))
+			 ;; (... ...) escape
+			 (k (car tmpl) (list (car tmpl)) '()) 
+			 (recur (car tmpl) (+ rank 1) '()
+				(lambda (comp1 ins1 op1)
+				  (if (null? op1)
+				      (error "Bad ellipsis:"
+					     tmpl " in template " template))
+				  (recur (cddr tmpl) rank inserted
+					 (lambda (comp2 ins2 op2)
+					   (k (cons
+					       (ellipsis-pattern comp1 op1)
+					       comp2)
+					      (append2 ins1 ins2)
+					      (append2 op1 op2)))))))
+		     (recur (car tmpl) rank '()
+			    (lambda (comp1 ins1 op1)
+			      (recur (cdr tmpl) rank inserted
+				     (lambda (comp2 ins2 op2)
+				       (k (cons comp1 comp2)
+					  (append2 ins1 ins2)
+					  (append2 op1 op2))))))))
+		(else
+		 (k tmpl '() '())))))
+
+
+;;; Match EXP to RULE, returning alist of variable bindings or #f.
+
+      (define (match literals rule exp env-def env-use)
+	(let recur ((r rule)
+		    (x (cdr exp)))
+	  (cond ((null? r)
+		 (and (null? x) '()))
+		((pair? r)
+		 (if (ellipsis-pattern? (car r))
+		     (and 
+		      (list? x)
+		      (let ((pat (ellipsis-pattern->pattern (car r))))
+			(let match1 ((x x)
+				     (vals '()))
+			  (if (null? x)
+			      (if (null? vals)
+				  (map list (ellipsis-pattern->vars (car r)))
+				  (let ((vars (map car (car vals))))
+				    (apply map list vars
+					   (map (lambda (al)
+						  (map cdr al))
+						(reverse vals)))))
+			      (let ((val (recur pat (car x))))
+				(and val
+				     (match1 (cdr x) (cons val vals))))))))
+		     (and
+		      (pair? x)
+		      (let ((v1 (recur (car r) (car x))))
+			(and v1
+			     (let ((v2 (recur (cdr r) (cdr x))))
+			       (and v2 (append2 v1 v2))))))))
+		((identifier? r)		;literal
+		 (and (identifier? x)
+		      (identifier-equal? (cdr (assq r literals)) x env-use)
+		      '()))
+		((pattern-variable? r)
+		 (list (cons r x)))
+		(else
+		 (and (equal? r x) '())))))
+
+      (define (substitute-in-template inserted template vars env-def)
+	(let ((ins (map (lambda (id)
+			  (cons id (renamed-identifier id env-def)))
+			inserted)))
+	  (let recur ((tmpl template)
+		      (vars vars))
+	    (cond ((null? tmpl)
+		   tmpl)
+		  ((pair? tmpl)
+		   (if (ellipsis-pattern? (car tmpl))
+		       (let ((enames (ellipsis-pattern->vars (car tmpl)))
+			     (etmpl (ellipsis-pattern->pattern (car tmpl))))
+			 (let ((evals (apply map list
+					     (map (lambda (nam)
+						    (cdr (assq nam vars)))
+						  enames))))
+			   (append!
+			    (map (lambda (eval)
+				   (recur etmpl
+					  (append!
+					   (map cons enames eval)
+					   vars)))
+				 evals)
+			    (recur (cdr tmpl) vars))))
+		       (cons (recur (car tmpl) vars)
+			     (recur (cdr tmpl) vars))))
+		  ((identifier? tmpl)
+		   (let ((a (assq tmpl ins)))
+		     (if a (cdr a) tmpl)))
+		  ((pattern-variable? tmpl)
+		   (@copy-tree (cdr (assq tmpl vars))))
+		  (else
+		   tmpl)))))
+
+      ;; MACRO:COMPILE-SYNTAX-RULES
+      (lambda (x-def env-def)
+	(or (and (list? x-def)
+		 (< 2 (length x-def))
+		 (list? (cadr x-def)))
+	    (error "Malformed syntax-rules:" x-def))
+	(let ((literals (cadr x-def)))
+	  (for-each (lambda (x)
+		      (or (identifier? x)
+			  (error "Bad literals list:" x-def)))
+		    literals)
+
+	  ;;Rules have the form: (<pattern> <inserted-identifiers> <template>).
+	  (let ((rules 
+		 (map
+		  (lambda (rule)
+		    (or (and (list? rule)
+			     (= 2 (length rule)))
+			(error "Bad rule:" rule))
+		    (compile-pattern literals rule env-def))
+		  (cddr x-def)))
+		(re-lits
+		 (map (lambda (sym)
+			(cons sym (renamed-identifier sym env-def)))
+		      literals)))
+	    
+	    (lambda (x-use env-use)
+	      (let loop ((rules rules))
+		(cond ((null? rules)
+		       (error "macro use does not match definition:"
+			      x-use))
+		      ((match re-lits (caar rules) x-use env-def env-use) 
+		       => (lambda (vars)
+			    (let ((r (car rules)))
+			      (substitute-in-template (cadr r) 
+						      (caddr r)
+						      vars
+						      env-def))))
+		      (else
+		       (loop (cdr rules))))))))))))
+
+(define syntax-rules
+  (procedure->syntax
+   (lambda (expr env-def)
+     (procedure->memoizing-macro
+      (macro:compile-syntax-rules expr env-def)))))
+
+(define define-syntax
+  (syntax-rules ()
+    ((define-syntax ?name ?val)
+     (define ?name (the-macro ?val)))))
+
+(define-syntax let-syntax
+  (syntax-rules () ((let-syntax ((?name ?val) ...) . ?body)
+		    (@let-syntax
+			((?name (the-macro ?val)) ...) . ?body))))
+
+(define-syntax letrec-syntax
+  (syntax-rules () ((letrec-syntax ((?name ?val) ...) . ?body)
+		    (@letrec-syntax
+		     ((?name (the-macro ?val)) ...) . ?body))))
+
+;; MACRO:EXPAND would require substantial work.
+(define macro:load load)
+(define macro:eval eval)
+(provide 'macro)