Eliminate special bindings for constants in pattern->spar.

Also change leading : to $ to avoid making names look like keywords.

diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm
index 7e3a1a5f5080dfc51e15b66876a9b36f93c8f02a..3aa4a9c943e3e82de7b9f8944aa8aebf452516f6 100644 (file)
--- a/src/runtime/syntax-parser.scm
+++ b/src/runtime/syntax-parser.scm
@@ -468,9 +468,8 @@ USA.
 
 (define (make-pattern-compiler expr? caller)
   (call-with-constructors expr?
-    (lambda (:* :+ :and :call :close :compare :cons :elt :eqv? :form :hist :id?
-               :if :list :match-elt :match-null :not :opt :or :push :push-elt
-               :push-elt-if :push-value :senv :symbol? :value)
+    (lambda ($* $+ $and $call $elt $if $match-elt $match-null $not $opt $or
+               $push $push-elt $push-elt-if $push-value)
 
       (define (loop pattern)
        (let-syntax
@@ -483,47 +482,50 @@ USA.
                                   ,@(cdr rule)))
                               (cdr form))
                        (else (bad-pattern pattern)))))))
-         (rules (''ignore (:elt))
-                (''any (:push-elt))
-                (''id (:push-elt-if (:id?) (:form)))
-                (''symbol (:push-elt-if (:symbol?) (:form)))
-                (procedure? (:push-elt-if pattern (:form)))
+         (rules (''ignore ($elt))
+                (''any ($push-elt))
+                (''id ($push-elt-if identifier? spar-arg:form))
+                (''symbol ($push-elt-if symbol? spar-arg:form))
+                (procedure? ($push-elt-if pattern spar-arg:form))
                 ('('spar form) (cadr pattern))
-                ('('* * form) (apply :* (map loop (cdr pattern))))
-                ('('+ * form) (apply :+ (map loop (cdr pattern))))
-                ('('? * form) (apply :opt (map loop (cdr pattern))))
-                ('('if form form form) (apply :if (map loop (cdr pattern))))
-                ('('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-elt (:eqv?) (cadr pattern) (:form)))
+                ('('* * form) (apply $* (map loop (cdr pattern))))
+                ('('+ * form) (apply $+ (map loop (cdr pattern))))
+                ('('? * form) (apply $opt (map loop (cdr pattern))))
+                ('('if form form form) (apply $if (map loop (cdr pattern))))
+                ('('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-elt eqv? (cadr pattern) spar-arg:form))
                 ('('noise-keyword identifier)
-                 (:match-elt (:compare) (cadr pattern) (:form)))
+                 ($match-elt spar-arg:compare (cadr pattern) spar-arg:form))
                 ('('keyword identifier)
-                 (:and (:match-elt (:compare) (cadr pattern) (:form))
-                       (:push (cadr pattern))))
+                 ($and ($match-elt spar-arg:compare
+                                   (cadr pattern)
+                                   spar-arg:form)
+                       ($push (cadr pattern))))
                 ('('values * form)
-                 (apply :push (map convert-spar-arg (cdr pattern))))
+                 (apply $push (map convert-spar-arg (cdr pattern))))
                 ('('value-of + form)
-                 (apply :push-value (map convert-spar-arg (cdr pattern))))
+                 (apply $push-value (map convert-spar-arg (cdr pattern))))
                 ('('list * form)
-                 (apply :call (:list) (map loop (cdr pattern))))
+                 (apply $call list (map loop (cdr pattern))))
                 ('('cons * form)
-                 (apply :call (:cons) (map loop (cdr pattern))))
+                 (apply $call cons (map loop (cdr pattern))))
                 ('('call + form)
-                 (apply :call (cadr pattern) (map loop (cddr pattern))))
+                 (apply $call (cadr pattern) (map loop (cddr pattern))))
                 ('('elt * form)
-                 (:elt (apply :and (map loop (cdr pattern)))
-                       (:match-null))))))
+                 ($elt (apply $and (map loop (cdr pattern)))
+                       ($match-null))))))
 
       (define (convert-spar-arg arg)
        (case arg
-         ((form) (:form))
-         ((hist) (:hist))
-         ((close) (:close))
-         ((compare) (:compare))
-         ((senv) (:senv))
-         ((value) (:value))
+         ((form) spar-arg:form)
+         ((hist) spar-arg:hist)
+         ((close) spar-arg:close)
+         ((compare) spar-arg:compare)
+         ((senv) spar-arg:senv)
+         ((value) spar-arg:value)
          (else arg)))
 
       (define (bad-pattern pattern)
@@ -532,8 +534,8 @@ USA.
       (lambda (pattern)
        (if (not (list? pattern))
            (bad-pattern pattern))
-       (:and (apply :and (map loop pattern))
-             (:match-null))))))
+       ($and (apply $and (map loop pattern))
+             ($match-null))))))
 \f
 (define (call-with-constructors expr? procedure)
 
@@ -555,25 +557,12 @@ USA.
                      (list expr)))
                exprs))
 
-  (define (const name value)
-    (if expr?
-       (lambda () name)
-       (lambda () value)))
-
   (procedure (flat-proc 'spar* spar*)
             (flat-proc 'spar+ spar+)
             (flat-proc 'spar-and spar-and)
             (flat-proc 'spar-call-with-values spar-call-with-values)
-            (const 'spar-arg:close spar-arg:close)
-            (const 'spar-arg:compare spar-arg:compare)
-            (const 'cons cons)
             (flat-proc 'spar-elt spar-elt)
-            (const 'eqv? eqv?)
-            (const 'spar-arg:form spar-arg:form)
-            (const 'spar-arg:hist spar-arg:hist)
-            (const 'identifier? identifier?)
             (proc 'spar-if spar-if)
-            (const 'list list)
             (proc 'spar-match-elt spar-match-elt)
             (proc 'spar-match-null spar-match-null)
             (proc 'spar-not spar-not)
@@ -582,10 +571,7 @@ USA.
             (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 'spar-arg:senv spar-arg:senv)
-            (const 'symbol? symbol?)
-            (const 'spar-arg:value spar-arg:value)))
+            (proc 'spar-push-value spar-push-value)))
 
 (define-deferred pattern->spar
   (make-pattern-compiler #f 'pattern->spar))