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 9a50080f56685d859c59c58dd6d04904ab6a3159..759e6c89621c5006dc96262d943ea0eeaa5566aa 100644 (file)
--- 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 e1ad647c72a1032ce826ff68bf8ca5dda4ee2f03..db0166255597d92e5b3328400e3024734314943c 100644 (file)
--- 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))))
-
+\f
 (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