Simplify spars pattern language.

Also change some of the terms to be clearer: I'm anticipating how the
documentation will read.

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index b72c3428d4db0754912a40a629f9cbed1c065092..a3bfb6731074c94495adc02ef8a1ae65e9c79451 100644 (file)
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -147,7 +147,7 @@ USA.
 (define :receive
   (spar-transformer->runtime
    (delay
-     (scons-rule '(r4rs-bvl expr (list (+ form)))
+     (scons-rule `(,r4rs-lambda-list? any (list (+ any)))
        (lambda (bvl expr body-forms)
         (scons-call 'call-with-values
                     (scons-lambda '() expr)
@@ -158,12 +158,12 @@ USA.
   (spar-transformer->runtime
    (delay
      (scons-rule
-        '((or (seq id (values #f))
-              (elt id expr))
-          (or (seq #f (values #f))
-              (seq id (values #f))
+        `((or (and id (values #f))
+              (elt id any))
+          (or (and id (values #f))
+              (and ,not (values #f))
               (elt id (list (* symbol))))
-          (or #f id)
+          (or id ,not)
           (list (* (list (elt symbol id (or id (values #f)))))))
        (lambda (type-name parent maker-name maker-args pred-name field-specs)
         (apply scons-begin
@@ -205,10 +205,7 @@ USA.
   (spar-transformer->runtime
    (delay
      (spar-or
-       (scons-rule
-          `(id
-            (or expr
-                (value-of ,unassigned-expression)))
+       (scons-rule `(id ,(optional-value-pattern))
         (lambda (name value)
           (scons-call keyword:define name value)))
        (scons-rule
@@ -216,7 +213,7 @@ USA.
              ,(spar-elt
                 (spar-push-elt-if identifier? spar-arg:form)
                 (spar-push-if mit-lambda-list? spar-arg:form)))
-            (list (+ form)))
+            (list (+ any)))
         (lambda (name bvl body-forms)
           (scons-define name
             (apply scons-named-lambda (cons name bvl) body-forms))))
@@ -225,11 +222,14 @@ USA.
              ,(spar-elt
                 (spar-push-elt spar-arg:form)
                 (spar-push-if mit-lambda-list? spar-arg:form)))
-            (list (+ form)))
+            (list (+ any)))
         (lambda (nested bvl body-forms)
           (scons-define nested
             (apply scons-lambda bvl body-forms))))))
    system-global-environment))
+
+(define (optional-value-pattern)
+  `(or any (value-of ,unassigned-expression)))
 \f
 (define :let
   (spar-transformer->runtime
@@ -237,7 +237,7 @@ USA.
      (scons-rule
         `((or id (values #f))
           ,(let-bindings-pattern)
-          (list (+ form)))
+          (list (+ any)))
        (lambda (name bindings body-forms)
         (let ((ids (map car bindings))
               (vals (map cadr bindings)))
@@ -251,10 +251,7 @@ USA.
    system-global-environment))
 
 (define (let-bindings-pattern)
-  `(elt (list
-        (* (elt (list id
-                      (or expr
-                          (value-of ,unassigned-expression))))))))
+  `(elt (list (* (elt (list id ,(optional-value-pattern)))))))
 
 (define named-let-strategy 'internal-definition)
 
@@ -296,7 +293,7 @@ USA.
    (delay
      (scons-rule
         `(,(let-bindings-pattern)
-          (list (+ form)))
+          (list (+ any)))
        (lambda (bindings body-forms)
         (expand-let* scons-let bindings body-forms))))
    system-global-environment))
@@ -305,8 +302,8 @@ USA.
   (spar-transformer->runtime
    (delay
      (scons-rule
-        '((elt (list (* (elt (list id expr)))))
-          (list (+ form)))
+        '((elt (list (* (elt (list id any)))))
+          (list (+ any)))
        (lambda (bindings body-forms)
         (expand-let* scons-let-syntax bindings body-forms))))
    system-global-environment))
@@ -324,7 +321,7 @@ USA.
    (delay
      (scons-rule
         `(,(let-bindings-pattern)
-          (list (+ form)))
+          (list (+ any)))
        (lambda (bindings body-forms)
         (let* ((ids (map car bindings))
                (vals (map cadr bindings))
@@ -343,7 +340,7 @@ USA.
    (delay
      (scons-rule
         `(,(let-bindings-pattern)
-          (list (+ form)))
+          (list (+ any)))
        (lambda (bindings body-forms)
         (let ((ids (map car bindings))
               (vals (map cadr bindings)))
@@ -357,7 +354,7 @@ USA.
 (define :and
   (spar-transformer->runtime
    (delay
-     (scons-rule '((list (* expr)))
+     (scons-rule '((list (* any)))
        (lambda (exprs)
         (if (pair? exprs)
             (let loop ((exprs exprs))

diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm
index 868f44fa9f7b454b6310c5ba14b0eb8506c58e16..40a264e0b1207cf81e1dba6a9f91738bde28e650 100644 (file)
--- a/src/runtime/syntax-parser.scm
+++ b/src/runtime/syntax-parser.scm
@@ -453,8 +453,8 @@ USA.
 (define (make-pattern-compiler expr? caller)
   (call-with-constructors expr?
     (lambda (:* :+ :call :close :compare :cons :elt :eqv? :form :hist :id? :list
-               :match-elt :match-null :mit-bvl? :not :opt :or :push :push-elt
-               :push-elt-if :push-value :r4rs-bvl? :senv :seq :symbol? :value)
+               :match-elt :match-null :opt :or :push :push-elt :push-elt-if
+               :push-value :senv :seq :symbol? :value)
 
       (define (loop pattern)
        (let-syntax
@@ -467,20 +467,17 @@ USA.
                                   ,@(cdr rule)))
                               (cdr form))
                        (else (bad-pattern pattern)))))))
-         (rules (''symbol (:push-elt-if (:symbol?) (:form)))
-                ('(or 'identifier 'id) (:push-elt-if (:id?) (:form)))
-                ('(or 'form 'expr) (:push-elt (:form)))
-                (''r4rs-bvl (:push-elt-if (:r4rs-bvl?) (:form)))
-                (''mit-bvl (:push-elt-if (:mit-bvl?) (:form)))
-                (''ignore (:elt))
-                (not (:push-elt-if (:not) (:form)))
+         (rules (''ignore (:elt))
+                (''any (:push-elt (:form)))
+                (''id (:push-elt-if (:id?) (:form)))
+                (''symbol (:push-elt-if (:symbol?) (:form)))
                 (procedure? (:push-elt-if pattern (:form)))
                 ('('spar form) (cadr pattern))
                 ('('* * form) (apply :* (map loop (cdr pattern))))
                 ('('+ * form) (apply :+ (map loop (cdr pattern))))
                 ('('? * form) (apply :opt (map loop (cdr pattern))))
                 ('('or * form) (apply :or (map loop (cdr pattern))))
-                ('('seq * form) (apply :seq (map loop (cdr pattern))))
+                ('('and * form) (apply :seq (map loop (cdr pattern))))
                 ('('quote form) (:match-elt (:eqv?) (cadr pattern) (:form)))
                 ('('keyword identifier)
                  (:match-elt (:compare) (cadr pattern) (:form)))
@@ -556,15 +553,12 @@ USA.
             (const 'list list)
             (proc 'spar-match-elt spar-match-elt)
             (proc 'spar-match-null spar-match-null)
-            (const 'mit-lambda-list? mit-lambda-list?)
-            (const 'not not)
             (flat-proc 'spar-opt spar-opt)
             (proc 'spar-or spar-or)
             (proc 'spar-push spar-push)
             (proc 'spar-push-elt spar-push-elt)
             (proc 'spar-push-elt-if spar-push-elt-if)
             (proc 'spar-push-value spar-push-value)
-            (const 'r4rs-lambda-list? r4rs-lambda-list?)
             (const 'spar-arg:senv spar-arg:senv)
             (flat-proc 'spar-seq spar-seq)
             (const 'symbol? symbol?)