Refactor how keywords are matched.

* spar-arg:compare renamed to spar-arg:id=? and second argument is optional,
  defaulting to spar-arg:form.

* patterns (noise ...), (noise-keyword ...), and (keyword ...) are eliminated.

* New pattern (ignore-if predicate arg...) ignores a subform if calling the
  predicate is satisfied.

* Renamed (value-if ...) to (keep-if ...) with same semantics: keeps a subform
  if calling the predicate is satisfied.

* New pattern (value arg) is like (values arg...) but a little clearer.

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index a91ff3bf63637cfb40bf59ff077c14297bf003f4..ecbae2cc285a89eb765d70f5fc0b88615fcc41a2 100644 (file)
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -43,25 +43,25 @@ USA.
        (spar-subform
          (spar-call-with-values list
            (spar-or
-             (spar-and (spar-push-subform-if spar-arg:compare 'or spar-arg:form)
+             (spar-and (spar-push-subform-if spar-arg:id=? 'or)
                        (spar* clause-pattern*)
                        (spar-match-null))
-             (spar-and (spar-push-subform-if spar-arg:compare 'and spar-arg:form)
+             (spar-and (spar-push-subform-if spar-arg:id=? 'and)
                        (spar* clause-pattern*)
                        (spar-match-null))
-             (spar-and (spar-push-subform-if spar-arg:compare 'not spar-arg:form)
+             (spar-and (spar-push-subform-if spar-arg:id=? 'not)
                        clause-pattern*
                        (spar-match-null))))))))
-  `((values compare)
+  `((value id=?)
     (+ (subform (cons (spar ,clause-pattern)
                      (* any))))))
 
-(define (generate-cond-expand compare clauses)
+(define (generate-cond-expand id=? clauses)
 
   (define (process-clauses clauses)
     (cond ((not (pair? clauses))
           (generate '()))
-         ((compare 'else (caar clauses))
+         ((id=? 'else (caar clauses))
           (if (pair? (cdr clauses))
               (syntax-error "ELSE clause must be last:" clauses))
           (generate (cdar clauses)))
@@ -76,15 +76,15 @@ USA.
 
   (define (eval-req req success failure)
     (cond ((identifier? req) (if (supported-feature? req) (success) (failure)))
-         ((compare 'or (car req)) (eval-or (cdr req) success failure))
-         ((compare 'and (car req)) (eval-and (cdr req) success failure))
-         ((compare 'not (car req)) (eval-req (cadr req) failure success))
+         ((id=? 'or (car req)) (eval-or (cdr req) success failure))
+         ((id=? 'and (car req)) (eval-and (cdr req) success failure))
+         ((id=? 'not (car req)) (eval-req (cadr req) failure success))
          (else (error "Unknown requirement:" req))))
 
   (define (supported-feature? req)
     (let ((p
           (find (lambda (p)
-                  (compare (car p) req))
+                  (id=? (car p) req))
                 supported-features)))
       (and p
           ((cdr p)))))
@@ -182,13 +182,13 @@ USA.
   (spar-transformer->runtime
    (delay
      (scons-rule
-        `((or (and id (values #f))
+        `((or (and id (value #f))
               (subform id any))
-          (or (and id (values #f))
-              (and ,not (values #f))
+          (or (and id (value #f))
+              (and ,not (value #f))
               (subform id (* symbol)))
           (or id ,not)
-          (* (subform (list symbol id (or id (values #f))))))
+          (* (subform (list symbol id (or id (value #f))))))
        (lambda (type-name parent maker-name maker-args pred-name field-specs)
         (apply scons-begin
                (scons-define type-name
@@ -261,7 +261,7 @@ USA.
   (spar-transformer->runtime
    (delay
      (scons-rule
-        `((or id (values #f))
+        `((or id (value #f))
           ,(let-bindings-pattern)
           (+ any))
        (lambda (name bindings body-forms)
@@ -391,17 +391,17 @@ USA.
    (delay
      (scons-rule
         (let ((action-pattern
-               '(if (noise-keyword =>)
-                    (list (values =>)
+               '(if (ignore-if id=? =>)
+                    (list (value =>)
                           any)
-                    (cons (values begin)
+                    (cons (value begin)
                           (+ any)))))
           `(any
             (* (subform (cons (subform (* any))
                               ,action-pattern)))
-            (or (subform (noise-keyword else)
+            (or (subform (ignore-if id=? else)
                          ,action-pattern)
-                (values #f))))
+                (value #f))))
        (lambda (expr clauses else-clause)
         (let ((temp (new-identifier 'key)))
 
@@ -446,9 +446,9 @@ USA.
    (delay
      (scons-rule
         `((* ,cond-clause-pattern)
-          (or (subform (noise-keyword else)
+          (or (subform (ignore-if id=? else)
                        (+ any))
-              (values #f)))
+              (value #f)))
        (lambda (clauses else-actions)
         (fold-right expand-cond-clause
                     (if else-actions
@@ -458,12 +458,12 @@ USA.
    system-global-environment))
 
 (define cond-clause-pattern
-  '(subform (cons (and (not (noise-keyword else))
+  '(subform (cons (and (not (ignore-if id=? else))
                       any)
-                 (if (noise-keyword =>)
-                     (list (values =>)
+                 (if (ignore-if id=? =>)
+                     (list (value =>)
                            any)
-                     (cons (values begin)
+                     (cons (value begin)
                            (* any))))))
 
 (define (expand-cond-clause clause rest)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 322738e95a2bbaee4a58111e126ea7cde50da2a6..bcbe35e44d07a2491a3e51be0aff3d5855e54ba0 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4551,9 +4551,9 @@ USA.
          spar+
          spar-append-map-values
          spar-arg:close
-         spar-arg:compare
          spar-arg:form
          spar-arg:hist
+         spar-arg:id=?
          spar-arg:senv
          spar-arg:value
          spar-arg:values

diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm
index 21eb564637caaee214d99239fc68654f36330fcf..e2a662311fd88371d90d814191cd62184050f1e4 100644 (file)
--- a/src/runtime/syntax-parser.scm
+++ b/src/runtime/syntax-parser.scm
@@ -155,10 +155,10 @@ USA.
   (cond ((eq? arg spar-arg:form) (%input-form input))
        ((eq? arg spar-arg:hist) (%input-hist input))
        ((eq? arg spar-arg:close) (make-closer (%input-closing-senv input)))
-       ((eq? arg spar-arg:compare)
-        (make-comparer (%input-closing-senv input) senv))
        ((eq? arg spar-arg:ctx)
         (serror-ctx (%input-form input) senv (%input-hist input)))
+       ((eq? arg spar-arg:id=?)
+        (make-comparer (%input-closing-senv input) senv (%input-form input)))
        ((eq? arg spar-arg:senv) senv)
        ((eq? arg spar-arg:value) (%output-top output))
        ((eq? arg spar-arg:values) (%output-all output))
@@ -168,16 +168,17 @@ USA.
   (lambda (expr)
     (close-syntax expr closing-senv)))
 
-(define (make-comparer closing-senv use-senv)
-  (lambda (reference form)
-    (and (identifier? form)
-        (identifier=? closing-senv reference use-senv form))))
+(define (make-comparer closing-senv use-senv form)
+  (lambda (reference #!optional comparand)
+    (let ((comparand (if (default-object? comparand) form comparand)))
+      (and (identifier? comparand)
+          (identifier=? closing-senv reference use-senv comparand)))))
 
 (define-deferred spar-arg:form (string->uninterned-symbol ".form."))
 (define-deferred spar-arg:hist (string->uninterned-symbol ".hist."))
 (define-deferred spar-arg:close (string->uninterned-symbol ".close."))
-(define-deferred spar-arg:compare (string->uninterned-symbol ".compare."))
 (define-deferred spar-arg:ctx (string->uninterned-symbol ".ctx."))
+(define-deferred spar-arg:id=? (string->uninterned-symbol ".id=?."))
 (define-deferred spar-arg:senv (string->uninterned-symbol ".senv."))
 (define-deferred spar-arg:value (string->uninterned-symbol ".value."))
 (define-deferred spar-arg:values (string->uninterned-symbol ".values."))
@@ -495,17 +496,12 @@ USA.
                 ('('or * form) (apply $or (map loop (cdr pattern))))
                 ('('and * form) (apply $and (map loop (cdr pattern))))
                 ('('not form) ($not (loop (cadr pattern))))
-                ('('noise form)
-                 ($match-subform eqv? (cadr pattern) spar-arg:form))
-                ('('noise-keyword identifier)
-                 ($match-subform spar-arg:compare
-                                 (cadr pattern)
-                                 spar-arg:form))
-                ('('keyword identifier)
-                 ($and ($match-subform spar-arg:compare
-                                       (cadr pattern)
-                                       spar-arg:form)
-                       ($push (cadr pattern))))
+                ('('ignore-if + form)
+                 (apply $match-subform (map convert-spar-arg (cdr pattern))))
+                ('('keep-if + form)
+                 (apply $push-subform-if (map convert-spar-arg (cdr pattern))))
+                ('('value * form)
+                 ($push (convert-spar-arg (cadr pattern))))
                 ('('values * form)
                  (apply $push (map convert-spar-arg (cdr pattern))))
                 ('('value-of + form)
@@ -525,7 +521,7 @@ USA.
          ((form) spar-arg:form)
          ((hist) spar-arg:hist)
          ((close) spar-arg:close)
-         ((compare) spar-arg:compare)
+         ((id=?) spar-arg:id=?)
          ((senv) spar-arg:senv)
          ((value) spar-arg:value)
          (else arg)))