Tweak pattern->spar to make it more useful.

Also add (cons* ...) pattern.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 82b154b2eac64978eb772362271a10a2049c9325..0c81c6573f9f203002fb8701578be82d2deed1f6 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4644,7 +4644,8 @@ USA.
          spar-subform
          spar-succeed
          spar-transform-values
-         spar-with-mapped-senv)
+         spar-with-mapped-senv
+         top-level-patterns->spar)
   (export (runtime syntax)
          spar-arg:ctx
          spar-call

diff --git a/src/runtime/syntax-constructor.scm b/src/runtime/syntax-constructor.scm
index e706fd2d7e785e6716854aca88bd8dd52adadb62..4d4650a19275d2880f2f32f9c40c26d42888fc2c 100644 (file)
--- a/src/runtime/syntax-constructor.scm
+++ b/src/runtime/syntax-constructor.scm
@@ -29,13 +29,13 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define (scons-rule pattern procedure)
+(define (scons-rule patterns procedure)
   (spar-call-with-values
       (lambda (close . args)
        (close-part close (apply procedure args)))
     (spar-subform)
     (spar-push spar-arg:close)
-    (pattern->spar pattern)))
+    (top-level-patterns->spar patterns)))
 
 (define-record-type <open-expr>
     (make-open-expr procedure)

diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm
index e2a662311fd88371d90d814191cd62184050f1e4..b4ccd115b2dd426cb96098dff574abb3f52b1477 100644 (file)
--- a/src/runtime/syntax-parser.scm
+++ b/src/runtime/syntax-parser.scm
@@ -510,6 +510,8 @@ USA.
                  (apply $call list (map loop (cdr pattern))))
                 ('('cons * form)
                  (apply $call cons (map loop (cdr pattern))))
+                ('('cons* * form)
+                 (apply $call cons* (map loop (cdr pattern))))
                 ('('call + form)
                  (apply $call (cadr pattern) (map loop (cddr pattern))))
                 ('('subform * form)
@@ -529,11 +531,7 @@ USA.
       (define (bad-pattern pattern)
        (error:wrong-type-argument pattern "syntax-parser pattern" caller))
 
-      (lambda (pattern)
-       (if (not (list? pattern))
-           (bad-pattern pattern))
-       ($and (apply $and (map loop pattern))
-             ($match-null))))))
+      loop)))
 \f
 (define (call-with-constructors expr? procedure)
 
@@ -575,4 +573,8 @@ USA.
   (make-pattern-compiler #f 'pattern->spar))
 
 (define-deferred pattern->spar-expr
-  (make-pattern-compiler #t 'pattern->spar-expr))
\ No newline at end of file
+  (make-pattern-compiler #t 'pattern->spar-expr))
+
+(define (top-level-patterns->spar patterns)
+  (spar-and (apply spar-and (map pattern->spar patterns))
+           (spar-match-null)))
\ No newline at end of file