From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 30 Nov 2018 06:45:50 +0000 (-0800)
Subject: syntax-rules: eliminate use of rename for creating new identifiers.
X-Git-Tag: mit-scheme-pucked-10.1.7~3^2~28
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a04378caa642239cabb3204dfd759899a7c84426;p=mit-scheme.git

syntax-rules: eliminate use of rename for creating new identifiers.

This confusion is one of several that has resulted from long-term muddy thinking
on my part, and is a contributor to the bug that was filed.

Also, clean up the code a bit in preparation for further changes required by
R7RS.
---

diff --git a/src/runtime/syntax-rules.scm b/src/runtime/syntax-rules.scm
index 7ba5c7d98..434cf511f 100644
--- a/src/runtime/syntax-rules.scm
+++ b/src/runtime/syntax-rules.scm
@@ -45,29 +45,30 @@ USA.
 	     (and (pair? keywords)
 		  (or (memq (car keywords) (cdr keywords))
 		      (loop (cdr keywords)))))
-	   (syntax-error "Keywords list contains duplicates:" keywords)
-	   (let ((r-form (rename 'form))
-		 (r-rename (rename 'rename))
-		 (r-compare (rename 'compare)))
-	     `(,(rename 'er-macro-transformer)
-	       (,(rename 'lambda)
-		(,r-form ,r-rename ,r-compare)
-		(,(rename 'declare) (ignorable ,r-rename ,r-compare))
-		,(let loop ((clauses clauses))
-		   (if (pair? clauses)
-		       (let ((pattern (caar clauses)))
-			 (let ((sids
-				(parse-pattern rename compare keywords
-					       pattern r-form)))
-			   `(,(rename 'if)
-			     ,(generate-match rename compare keywords
-					      r-rename r-compare
-					      pattern r-form)
-			     ,(generate-output rename compare r-rename
-					       sids (cadar clauses))
-			     ,(loop (cdr clauses)))))
-		       `(,(rename 'begin)
-			 (,(rename 'ill-formed-syntax) ,r-form))))))))))))
+	   (syntax-error "Keywords list contains duplicates:" keywords))
+       (let ((r-form (new-identifier 'form))
+	     (r-rename (new-identifier 'rename))
+	     (r-compare (new-identifier 'compare)))
+	 `(,(rename 'er-macro-transformer)
+	   (,(rename 'lambda)
+	    (,r-form ,r-rename ,r-compare)
+	    (,(rename 'declare) (ignorable ,r-rename ,r-compare))
+	    ,(let loop ((clauses clauses))
+	       (if (pair? clauses)
+		   (let ((pattern (caar clauses)))
+		     (let ((sids
+			    (parse-pattern rename compare keywords
+					   pattern r-form)))
+		       `(,(rename 'if)
+			 ,(generate-match rename compare keywords
+					  r-rename r-compare
+					  pattern r-form)
+			 ,(generate-output rename compare r-rename
+					   sids (cadar clauses))
+			 ,(loop (cdr clauses)))))
+		   `(,(rename 'begin)
+		     (,(rename 'ill-formed-syntax)
+		      (,(rename 'quote) ,r-form))))))))))))
 
 (define (parse-pattern rename compare keywords pattern expression)
   (let loop
@@ -79,10 +80,10 @@ USA.
 	   (if (memq pattern keywords)
 	       sids
 	       (cons (make-sid pattern expression control) sids)))
-	  ((and (or (zero-or-more? pattern rename compare)
-		    (at-least-one? pattern rename compare))
-		(null? (cddr pattern)))
-	   (let ((variable ((make-local-identifier-renamer) 'control)))
+	  ((zero-or-more? rename compare pattern)
+	   (if (not (null? (cddr pattern)))
+	       (syntax-error "Misplaced ellipsis:" pattern))
+	   (let ((variable (new-identifier 'control)))
 	     (loop (car pattern)
 		   variable
 		   sids
@@ -96,6 +97,13 @@ USA.
 		       control)
 		 control))
 	  (else sids))))
+
+(define-record-type <sid>
+    (make-sid name expression control)
+    sid?
+  (name sid-name)
+  (expression sid-expression)
+  (control sid-control))
 
 (define (generate-match rename compare keywords r-rename r-compare
 			pattern expression)
@@ -104,39 +112,25 @@ USA.
 	(lambda (pattern expression)
 	  (cond ((identifier? pattern)
 		 (if (memq pattern keywords)
-		     (let ((temp (rename 'temp)))
-		       `((,(rename 'lambda)
-			  (,temp)
-			  (,(rename 'if)
-			   (,(rename 'identifier?) ,temp)
-			   (,r-compare ,temp
-				       (,r-rename ,(syntax-quote pattern)))
-			   #f))
-			 ,expression))
+		     (let-ify rename expression
+		       (lambda (expr)
+			 `(,(rename 'and)
+			   (,(rename 'identifier?) ,expr)
+			   (,r-compare ,expr
+				       (,r-rename ,(syntax-quote pattern))))))
 		     `#t))
-		((and (zero-or-more? pattern rename compare)
-		      (null? (cddr pattern)))
+		((zero-or-more? rename compare pattern)
+		 ;; (cddr pattern) guaranteed null by parser above.
 		 (do-list (car pattern) expression))
-		((and (at-least-one? pattern rename compare)
-		      (null? (cddr pattern)))
-		 `(,(rename 'if) (,(rename 'null?) ,expression)
-				 #f
-				 ,(do-list (car pattern) expression)))
 		((pair? pattern)
-		 (let ((generate-pair
-			(lambda (expression)
-			  (conjunction
-			   `(,(rename 'pair?) ,expression)
-			   (conjunction
-			    (loop (car pattern)
-				  `(,(rename 'car) ,expression))
-			    (loop (cdr pattern)
-				  `(,(rename 'cdr) ,expression)))))))
-		   (if (identifier? expression)
-		       (generate-pair expression)
-		       (let ((temp (rename 'temp)))
-			 `((,(rename 'lambda) (,temp) ,(generate-pair temp))
-			   ,expression)))))
+		 (let-ify rename expression
+		   (lambda (expr)
+		     `(,(rename 'and)
+		       (,(rename 'pair?) ,expr)
+		       ,(loop (car pattern)
+			      `(,(rename 'car) ,expr))
+		       ,(loop (cdr pattern)
+			      `(,(rename 'cdr) ,expr))))))
 		((null? pattern)
 		 `(,(rename 'null?) ,expression))
 		(else
@@ -144,47 +138,43 @@ USA.
 				     (,(rename 'quote) ,pattern))))))
        (do-list
 	(lambda (pattern expression)
-	  (let ((r-loop (rename 'loop))
-		(r-l (rename 'l))
-		(r-lambda (rename 'lambda)))
-	    `(((,r-lambda
-		()
-		(,(rename 'define)
-		 ,r-loop
-		 (,r-lambda
-		  (,r-l)
-		  (,(rename 'if)
-		   (,(rename 'null?) ,r-l)
-		   #t
-		   ,(conjunction
-		     `(,(rename 'pair?) ,r-l)
-		     (conjunction (loop pattern `(,(rename 'car) ,r-l))
-				  `(,r-loop (,(rename 'cdr) ,r-l)))))))
-		,r-loop))
-	      ,expression))))
-       (conjunction
-	(lambda (predicate consequent)
-	  (cond ((eq? predicate #t) consequent)
-		((eq? consequent #t) predicate)
-		(else `(,(rename 'if) ,predicate ,consequent #f))))))
+	  (let ((r-loop (new-identifier 'loop))
+		(r-l (new-identifier 'l)))
+	    `((,(rename 'let)
+	       ()
+	       (,(rename 'define)
+		(,r-loop ,r-l)
+		(,(rename 'if)
+		 (,(rename 'null?) ,r-l)
+		 #t
+		 (,(rename 'and)
+		  (,(rename 'pair?) ,r-l)
+		  ,(loop pattern `(,(rename 'car) ,r-l))
+		  (,r-loop (,(rename 'cdr) ,r-l)))))
+	       ,r-loop)
+	      ,expression)))))
     (loop pattern expression)))
+
+(define (let-ify rename expression generate-body)
+  (if (identifier? expression)
+      (generate-body expression)
+      (let ((temp (new-identifier 'temp)))
+	`(,(rename 'let) ((,temp ,expression)) ,(generate-body temp)))))
 
 (define (generate-output rename compare r-rename sids template)
   (let loop ((template template) (ellipses '()))
     (cond ((identifier? template)
 	   (let ((sid
-		  (let loop ((sids sids))
-		    (and (pair? sids)
-			 (if (eq? (sid-name (car sids)) template)
-			     (car sids)
-			     (loop (cdr sids)))))))
+		  (find (lambda (sid)
+			  (eq? (sid-name sid) template))
+			sids)))
 	     (if sid
 		 (begin
 		   (add-control! sid ellipses)
 		   (sid-expression sid))
+		 ;; Template is a keyword:
 		 `(,r-rename ,(syntax-quote template)))))
-	  ((or (zero-or-more? template rename compare)
-	       (at-least-one? template rename compare))
+	  ((zero-or-more? rename compare template)
 	   (optimized-append rename compare
 			     (let ((ellipsis (make-ellipsis '())))
 			       (generate-ellipsis rename
@@ -201,54 +191,62 @@ USA.
 	   `(,(rename 'quote) ,template)))))
 
 (define (add-control! sid ellipses)
-  (let loop ((sid sid) (ellipses ellipses))
-    (let ((control (sid-control sid)))
-      (cond (control
-	     (if (pair? ellipses)
-		 (let ((sids (ellipsis-sids (car ellipses))))
-		   (cond ((not (memq control sids))
-			  (set-ellipsis-sids! (car ellipses)
-					      (cons control sids)))
-			 ((not (eq? control (car sids)))
-			  (error "illegal control/ellipsis combination"
-				 control sids))))
-		 (syntax-error "Missing ellipsis in expansion." #f))
-	     (loop control (cdr ellipses)))))))
+  (let ((control (sid-control sid)))
+    (if control
+	(begin
+	  (if (not (pair? ellipses))
+	      (syntax-error "Missing ellipsis in expansion."))
+	  (let ((sids (ellipsis-sids (car ellipses))))
+	    (if (memq control sids)
+		(if (not (eq? control (car sids)))
+		    (error "illegal control/ellipsis combination:"
+			   control sids))
+		(set-ellipsis-sids! (car ellipses) (cons control sids))))
+	  (add-control! control (cdr ellipses))))))
 
 (define (generate-ellipsis rename ellipsis body)
+  ;; Generation of body will have filled in the sids:
   (let ((sids (ellipsis-sids ellipsis)))
-    (if (pair? sids)
-	(let ((name (sid-name (car sids)))
-	      (expression (sid-expression (car sids))))
-	  (cond ((and (null? (cdr sids))
-		      (eq? body name))
-		 expression)
-		((and (null? (cdr sids))
-		      (pair? body)
-		      (pair? (cdr body))
-		      (eq? (cadr body) name)
-		      (null? (cddr body)))
-		 `(,(rename 'map) ,(car body) ,expression))
-		(else
-		 `(,(rename 'map) (,(rename 'lambda) ,(map sid-name sids)
-						     ,body)
-				  ,@(map sid-expression sids)))))
-	(syntax-error "Missing ellipsis in expansion." #f))))
+    (if (not (pair? sids))
+	(syntax-error "Missing ellipsis in expansion."))
+    ;; Optimize trivial case:
+    (if (and (eq? body (sid-name (car sids)))
+	     (null? (cdr sids)))
+	(sid-expression (car sids))
+	`(,(rename 'map) (,(rename 'lambda) ,(map sid-name sids) ,body)
+			 ,@(map sid-expression sids)))))
+
+(define-record-type <ellipsis>
+    (make-ellipsis sids)
+    ellipsis?
+  (sids ellipsis-sids set-ellipsis-sids!))
 
-(define (zero-or-more? pattern rename compare)
+(define (optimized-append rename compare x y)
+  (cond ((constant-null? rename compare x) y)
+	((constant-null? rename compare y) x)
+	(else `(,(rename 'append) ,x ,y))))
+
+(define (optimized-cons rename compare a d)
+  (cond ((and (constant? rename compare a)
+	      (constant? rename compare d))
+	 `(,(rename 'quote)
+	   ,(cons (constant->datum rename compare a)
+		  (constant->datum rename compare d))))
+	((constant-null? rename compare d)
+	 `(,(rename 'list) ,a))
+	((and (pair? d)
+	      (compare (car d) (rename 'list))
+	      (list? (cdr d)))
+	 `(,(rename 'list) ,a ,@(cdr d)))
+	(else
+	 `(,(rename 'cons) ,a ,d))))
+
+(define (zero-or-more? rename compare pattern)
   (and (pair? pattern)
        (pair? (cdr pattern))
        (identifier? (cadr pattern))
        (compare (cadr pattern) (rename '...))))
 
-(define (at-least-one? pattern rename compare)
-;;;  (and (pair? pattern)
-;;;       (pair? (cdr pattern))
-;;;       (identifier? (cadr pattern))
-;;;       (compare (cadr pattern) (rename '+)))
-  pattern rename compare		;ignore
-  #f)
-
 (define (syntax-quote expression)
   `(,(classifier->keyword
       (lambda (form senv hist)
@@ -256,38 +254,29 @@ USA.
 	(constant-item (serror-ctx form senv hist) (cadr form))))
     ,expression))
 
-(define (optimized-cons rename compare a d)
-  (cond ((and (pair? d)
-	      (compare (car d) (rename 'quote))
-	      (pair? (cdr d))
-	      (null? (cadr d))
-	      (null? (cddr d)))
-	 `(,(rename 'list) ,a))
-	((and (pair? d)
-	      (compare (car d) (rename 'list))
-	      (list? (cdr d)))
-	 `(,(car d) ,a ,@(cdr d)))
-	(else
-	 `(,(rename 'cons) ,a ,d))))
+(define (constant-null? rename compare expr)
+  (and (quoted? rename compare expr)
+       (eqv? '() (quoted-datum expr))))
 
-(define (optimized-append rename compare x y)
-  (if (and (pair? y)
-	   (compare (car y) (rename 'quote))
-	   (pair? (cdr y))
-	   (null? (cadr y))
-	   (null? (cddr y)))
-      x
-      `(,(rename 'append) ,x ,y)))
+(define (constant? rename compare expr)
+  (or (quoted? rename compare expr)
+      (boolean? expr)
+      (bytevector? expr)
+      (char? expr)
+      (number? expr)
+      (string? expr)
+      (vector? expr)))
 
-(define-record-type <sid>
-    (make-sid name expression control)
-    sid?
-  (name sid-name)
-  (expression sid-expression)
-  (control sid-control)
-  (output-expression sid-output-expression set-sid-output-expression!))
+(define (constant->datum rename compare expr)
+  (if (quoted? rename compare expr)
+      (quoted-datum expr)
+      expr))
 
-(define-record-type <ellipsis>
-    (make-ellipsis sids)
-    ellipsis?
-  (sids ellipsis-sids set-ellipsis-sids!))
\ No newline at end of file
+(define (quoted-datum expr)
+  (cadr expr))
+
+(define (quoted? rename compare expr)
+  (and (pair? expr)
+       (compare (car expr) (rename 'quote))
+       (pair? (cdr expr))
+       (null? (cddr expr))))
\ No newline at end of file