From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 20 May 2018 00:23:03 +0000 (-0700)
Subject: Tweak pattern->spar to make it more useful.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~28
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=151b656606e6cd29a57355b9d85645a302525dc5;p=mit-scheme.git

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 82b154b2e..0c81c6573 100644
--- 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 e706fd2d7..4d4650a19 100644
--- a/src/runtime/syntax-constructor.scm
+++ b/src/runtime/syntax-constructor.scm
@@ -29,13 +29,13 @@ USA.
 
 (declare (usual-integrations))
 
-(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 e2a662311..b4ccd115b 100644
--- 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)))
 
 (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