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

Fix bug #63568.

Didn't read the spec closely enough.  Vars bound in pattern segments are
supposed to be treated differently from those that aren't.  In particular,
non-segment vars are allowed inside template segments.
---

diff --git a/src/runtime/syntax-rules.scm b/src/runtime/syntax-rules.scm
index 9a50080f5..759e6c896 100644
--- a/src/runtime/syntax-rules.scm
+++ b/src/runtime/syntax-rules.scm
@@ -26,6 +26,7 @@ USA.
 |#
 
 ;;;; Rule-based Syntactic Expanders
+;;; package: (runtime syntax syntax-rules)
 
 ;;; See "Syntactic Extensions in the Programming Language Lisp", by
 ;;; Eugene Kohlbecker, Ph.D. dissertation, Indiana University, 1986.
@@ -246,7 +247,8 @@ USA.
 (define (check-template-var-references names depth pvs)
   (let ((pvs*
 	 (filter (lambda (pv)
-		   (memq (car pv) names))
+		   (and (memq (car pv) names)
+			(pair? (cdr pv))))
 		 pvs)))
     ;; All vars in segment must have correct depth.
     (let ((pvs**
@@ -402,11 +404,13 @@ USA.
 
 (define-integrable (new-dict) (make-dict '()))
 (define-integrable (make-dict bindings) bindings)
-(define-integrable (dict-add id datum dict) (cons (make-binding id datum) dict))
+(define-integrable (dict-add id datum dict)
+  (cons (make-binding id datum #f) dict))
 (define-integrable (dict-bindings dict) dict)
-(define-integrable (make-binding id datum) (list id datum))
+(define-integrable (make-binding id datum seg?) (list id datum seg?))
 (define-integrable (binding-id binding) (car binding))
 (define-integrable (binding-datum binding) (cadr binding))
+(define-integrable (binding-seg? binding) (caddr binding))
 (define no-datum (list 'no-datum))
 
 (define (dict-lookup id dict)
@@ -421,22 +425,28 @@ USA.
 	(if (pair? (car dicts))
 	    (cons (let ((per-id (map car dicts)))
 		    (make-binding (binding-id (car per-id))
-				  (reverse (map binding-datum per-id))))
+				  (reverse (map binding-datum per-id))
+				  #t))
 		  (join (map cdr dicts)))
 	     tail))
        tail))
 
 (define (unwrap-dict dict ids)
-  (let loop
-      ((items
-	(map (lambda (binding)
-	       (map (lambda (datum)
-		      (make-binding (binding-id binding) datum))
-		    (binding-datum binding)))
-	     (filter (lambda (binding)
-		       (memq (binding-id binding) ids))
-		     (dict-bindings dict)))))
-    (if (and (pair? items) (pair? (car items)))
-	(cons (make-dict (map car items))
-	      (loop (map cdr items)))
-	'())))
\ No newline at end of file
+  (let-values (((seg non-seg)
+		(partition binding-seg?
+			   (filter (lambda (binding)
+				     (memq (binding-id binding) ids))
+				   (dict-bindings dict)))))
+    (let loop
+	((items
+	  (map (lambda (binding)
+		 (let ((id (binding-id binding))
+		       (seg? (binding-seg? binding)))
+		   (map (lambda (datum)
+			  (make-binding id datum seg?))
+			(binding-datum binding))))
+	       seg)))
+      (if (and (pair? items) (pair? (car items)))
+	  (cons (make-dict (append non-seg (map car items)))
+		(loop (map cdr items)))
+	  '()))))
\ No newline at end of file
diff --git a/tests/runtime/test-syntax.scm b/tests/runtime/test-syntax.scm
index e1ad647c7..db0166255 100644
--- a/tests/runtime/test-syntax.scm
+++ b/tests/runtime/test-syntax.scm
@@ -365,7 +365,7 @@ USA.
 	 (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))))
-
+
 (define-test 'bug-63503
   (lambda ()
     (define-syntax foo
@@ -375,4 +375,20 @@ USA.
       (syntax-rules ()
 	((bar x)
 	 (foo keyword x))))
-    (assert-equal (bar 123) 123)))
\ No newline at end of file
+    (assert-equal (bar 123) 123)))
+
+(define-test 'bug-63568
+  (lambda ()
+    (assert-equal
+     (expand-expr '(lambda ()
+		     (define-syntax define-foo
+		       (syntax-rules ()
+			 ((define-foo ((variable value ...)))
+			  (begin
+			    (add-foo! '(variable value))
+			    ...))))
+		     (define-foo ((a 0 1 2)))))
+     '(lambda ()
+	(add-foo! '(a 0))
+	(add-foo! '(a 1))
+	(add-foo! '(a 2))))))
\ No newline at end of file