From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 11 Dec 2022 07:54:13 +0000 (-0800)
Subject: Fix bug #63503.
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=17b3e6fdf7f52c7a838bda2d8e9ce9124383b6d9;p=mit-scheme.git

Fix bug #63503.

Screwed up literal identifier matching during rewrite.
---

diff --git a/src/runtime/syntax-rules.scm b/src/runtime/syntax-rules.scm
index bd133f5fb..9a50080f5 100644
--- a/src/runtime/syntax-rules.scm
+++ b/src/runtime/syntax-rules.scm
@@ -83,9 +83,8 @@ USA.
 	 `(,(rename 'er-macro-transformer)
 	   (,(rename 'lambda)
 	    (,r-form ,r-rename ,r-compare)
-	    (,(rename 'declare) (ignore ,r-compare))
 	    ,@(if (null? clauses)
-		  `((,(rename 'declare) (ignore ,r-rename)))
+		  `((,(rename 'declare) (ignore ,r-rename ,r-compare)))
 		  '())
 	    ,(let loop
 		 ((clauses
@@ -98,7 +97,9 @@ USA.
 		     `(let ((,r-dict
 			     (,(rename 'syntax-rules:match-datum)
 			      ,(syntax-quote pattern)
-			      (cdr ,r-form))))
+			      (cdr ,r-form)
+			     ,r-rename
+			     ,r-compare)))
 			(if ,r-dict
 			    (,(rename 'syntax-rules:expand-template)
 			     ,(syntax-quote template)
@@ -265,7 +266,7 @@ USA.
 		(syntax-error "Mixed segments in template:"
 			      (map car pvs**))))))))
 
-(define (syntax-rules:match-datum pattern datum)
+(define (syntax-rules:match-datum pattern datum rename compare)
 
   (define (match-datum pat datum dict k)
 
@@ -288,7 +289,11 @@ USA.
 	   (lambda (pats datum dict)
 	     (match-datum (car pats) datum dict k))))
 	((literal)
-	 (and (equal? (car x) datum)
+	 (and (let ((literal (car x)))
+		(if (identifier? literal)
+		    (and (identifier? datum)
+			 (compare (rename literal) datum))
+		    (equal? literal datum)))
 	      (k dict)))
 	((var) (k (dict-add (car x) datum dict)))
 	((anon-var) (k dict))
diff --git a/tests/runtime/test-syntax.scm b/tests/runtime/test-syntax.scm
index f8697494b..e1ad647c7 100644
--- a/tests/runtime/test-syntax.scm
+++ b/tests/runtime/test-syntax.scm
@@ -364,4 +364,15 @@ USA.
 	((_ a b ... . c)
 	 (quote (a (b ...) c)))))
     (assert-equal (bar 1 2 3 4) '(1 (2 3 4) ()))
-    (assert-equal (bar 1 2 3 . 4) '(1 (2 3) 4))))
\ No newline at end of file
+    (assert-equal (bar 1 2 3 . 4) '(1 (2 3) 4))))
+
+(define-test 'bug-63503
+  (lambda ()
+    (define-syntax foo
+      (syntax-rules (keyword)
+	((foo keyword x) x)))
+    (define-syntax bar
+      (syntax-rules ()
+	((bar x)
+	 (foo keyword x))))
+    (assert-equal (bar 123) 123)))
\ No newline at end of file