From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 28 Mar 2018 05:00:16 +0000 (-0700)
Subject: Eliminate special bindings for constants in pattern->spar.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~166
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2bd5f07cf9ee65f7ac8d50c1acf46d9f4038cc4a;p=mit-scheme.git

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 7e3a1a5f5..3aa4a9c94 100644
--- 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))))))
 
 (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))