Import Upstream version 5d2upstream/5d2

1 files changed, 93 insertions, 62 deletions

diff --git a/Macro.scm b/Macro.scm
index 76fc495..0ddccc1 100644
--- a/Macro.scm
+++ b/Macro.scm
@@ -1,4 +1,4 @@
-;; Copyright (C) 1997, 1998 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 1998, 1999 Free Software Foundation, Inc.
 ;;
 ;; This program is free software; you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
@@ -12,7 +12,7 @@
 ;;
 ;; You should have received a copy of the GNU General Public License
 ;; along with this software; see the file COPYING.  If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 ;;
 ;; As a special exception, the Free Software Foundation gives permission
 ;; for additional uses of the text contained in its release of GUILE.
@@ -41,20 +41,20 @@
 ;;;; "Macro.scm", Support for syntax-rules macros.
 ;;; Author: Radey Shouman
 ;;
-;; As in SYNTAX-CASE, the identifier ... may be quoted in a 
+;; 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 
+;; 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 
+  ;; 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))
@@ -63,8 +63,9 @@
 		(and (the-macro and))
 		(or (the-macro or)))
     (let ((var-rtd (make-record-type '? '(name rank)))
-	  (e-pat-rtd (make-record-type '... '(pattern vars))))
-      
+	  (e-pat-rtd (make-record-type '... '(pattern vars)))
+	  (rule-rtd (make-record-type 'rule '(pattern inserted template))))
+
       (define pattern-variable (record-constructor var-rtd '(name rank)))
       (define pattern-variable? (record-predicate var-rtd))
       (define pattern-variable->name
@@ -82,10 +83,15 @@
       (define ellipsis-pattern->pattern (record-accessor e-pat-rtd 'pattern))
       (define ellipsis-pattern->vars (record-accessor e-pat-rtd 'vars))
 
+      (define rule (record-constructor rule-rtd '(pattern inserted template)))
+      (define rule->pattern (record-accessor rule-rtd 'pattern))
+      (define rule->inserted (record-accessor rule-rtd 'inserted))
+      (define rule->template (record-accessor rule-rtd 'template))
+
       (define (append2 x y)
 	(if (null? y) x
 	    (append x y)))
-      
+
       (define ellipsis?
 	(let (($... (renamed-identifier '... #f)))
 	  (lambda (x env)
@@ -101,25 +107,26 @@
 		(car vars)
 		(duplicates? (cdr vars)))))
 
-      (define (compile-pattern literals rule env-def)
-	(let recur ((pat (cdar rule))
+      (define (compile-pattern literals rule-exp env-def)
+	(let recur ((pat (cdar rule-exp))
 		    (vars '())
 		    (rank 0)
 		    (k (lambda (compiled vars)
 			 (let ((dup (duplicates? (map car vars))))
 			   (if dup
-			       (error 
+			       (error
 				"syntax-rules: duplicate pattern variable:"
-				dup " in rule " rule)))
-			 (cons compiled
-			       (rewrite-template
-				(cadr rule) vars env-def)))))
+				dup " in rule " rule-exp)))
+			 (apply rule
+				compiled
+				(rewrite-template
+				 (cadr rule-exp) vars env-def)))))
 	  (cond ((null? pat)
 		 (k pat vars))
 		((identifier? pat)
 		 (let ((lit (memq pat literals)))
 		   (if lit
-		       (k pat vars)
+		       (k (renamed-identifier pat env-def) vars)
 		       (let ((var (pattern-variable pat rank)))
 			 (k var (cons (cons pat var) vars))))))
 		((pair? pat)
@@ -146,7 +153,7 @@
 			  (k (list->vector comp) vars))))
 		(else
 		 (k pat vars)))))
-      
+
       (define (rewrite-template template vars env-def)
 	(let recur ((tmpl template)
 		    (rank 0)
@@ -173,7 +180,7 @@
 			      (or (null? (cddr tmpl))
 				  (error "bad ellipsis:" tmpl)))
 			 ;; (... ...) escape
-			 (k (car tmpl) (list (car tmpl)) '()) 
+			 (k (car tmpl) (list (car tmpl)) '())
 			 (recur (car tmpl) (+ rank 1) '()
 				(lambda (comp1 ins1 op1)
 				  (if (null? op1)
@@ -203,14 +210,14 @@
 
 ;;; Match EXP to RULE, returning alist of variable bindings or #f.
 
-      (define (match literals rule exp env-def env-use)
-	(let recur ((r rule)
+      (define (match rule exp env-use)
+	(let recur ((r (rule->pattern rule))
 		    (x (cdr exp)))
 	  (cond ((null? r)
 		 (and (null? x) '()))
 		((pair? r)
 		 (if (ellipsis-pattern? (car r))
-		     (and 
+		     (and
 		      (list? x)
 		      (let ((pat (ellipsis-pattern->pattern (car r))))
 			(let match1 ((x x)
@@ -233,9 +240,7 @@
 			     (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)
-		      '()))
+		 (and (identifier? x) (identifier-equal? r x env-use) '()))
 		((pattern-variable? r)
 		 (list (cons r x)))
 		((vector? r)
@@ -244,30 +249,35 @@
 		(else
 		 (and (equal? r x) '())))))
 
-      (define (substitute-in-template inserted template vars env-def)
+      (define (substitute-in-template rule vars env-def)
 	(let ((ins (map (lambda (id)
 			  (cons id (renamed-identifier id env-def)))
-			inserted)))
-	  (let recur ((tmpl template)
+			(rule->inserted rule))))
+	  (let recur ((tmpl (rule->template rule))
 		      (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))))
+		       (let* ((enames (ellipsis-pattern->vars (car tmpl)))
+			      (etmpl (ellipsis-pattern->pattern (car tmpl)))
+			      (evals (map (lambda (nam)
+					    (cdr (assq nam vars)))
+					  enames))
+			      (n (length (car evals))))
+			 (let check ((es (cdr evals)))
+			   (if (pair? es)
+			       (if (= n (length (car es)))
+				   (check (cdr es))
+				   (error "syntax-rules: pattern variable length mismatch:"))))
+			 (append!
+			  (map (lambda (eval)
+				 (recur etmpl
+					(append!
+					 (map cons enames eval)
+					 vars)))
+			       (apply map list evals))
+			  (recur (cdr tmpl) vars)))
 		       (cons (recur (car tmpl) vars)
 			     (recur (cdr tmpl) vars))))
 		  ((identifier? tmpl)
@@ -291,33 +301,22 @@
 		      (or (identifier? x)
 			  (error "Bad literals list:" x-def)))
 		    literals)
+	  (let ((rules (map (lambda (rule-expr)
+			      (or (and (list? rule-expr)
+				       (= 2 (length rule-expr))
+				       (pair? (car rule-expr)))
+				  (error "Bad rule:" rule-expr))
+			      (compile-pattern literals rule-expr env-def))
+			    (cddr x-def))))
 
-	  ;;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) 
+		      ((match (car rules) x-use env-use)
 		       => (lambda (vars)
-			    (let ((r (car rules)))
-			      (substitute-in-template (cadr r) 
-						      (caddr r)
-						      vars
-						      env-def))))
+			    (substitute-in-template (car rules) vars env-def)))
 		      (else
 		       (loop (cdr rules))))))))))))
 
@@ -327,6 +326,38 @@
      (procedure->memoizing-macro
       (macro:compile-syntax-rules expr env-def)))))
 
+;; Explicit renaming macro facility, as in
+;; W. Clinger, "Hygienic Macros Through Explicit Renaming"
+(define (macro:renaming-transformer-procedure proc env-def)
+  (procedure->memoizing-macro
+   (lambda (expr env-use)
+     (proc (@copy-tree expr)
+	   (let ((al '()))
+	     (lambda (id)
+	       (cond ((not (identifier? id))
+		      (error id "non-identifier passed to rename procedure"
+			     expr))
+		     ((assq id al) => cdr)
+		     (else
+		      (let ((r-id (renamed-identifier id env-def)))
+			(set! al (cons id r-id))
+			r-id)))))
+	   (lambda (id1 id2)
+	     (or (and (identifier? id1)
+		      (identifier? id2)
+		 (error (if (identifier? id1) id2 id1)
+			"non-identifier passed to compare procedure"
+			expr)))
+	     (identifier-equal? id1 id2 env-use))))))
+
+(define renaming-transformer
+  (let ((?transformer
+	 (renamed-identifier 'macro:renaming-transformer-procedure #f))
+	(?syntax-quote (renamed-identifier 'syntax-quote #f)))
+    (procedure->memoizing-macro
+     (lambda (exp env-def)
+       `(,?transformer ,(cadr exp) (,?syntax-quote ,env-def))))))
+
 (define define-syntax
   (syntax-rules ()
     ((define-syntax ?name ?val)