From 64a33f993618106e3cd49466703e4de161a6efb1 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 20 Feb 2018 23:27:45 -0800
Subject: [PATCH] Put error messages back into classifiers.

Also:
* Clean up spar API some more.
* Add spar-error for signalling errors.
* Add special args for specifying procedure args.
---
 src/runtime/mit-syntax.scm    | 194 ++++++++++++++-------------
 src/runtime/runtime.pkg       |  43 +++---
 src/runtime/syntax-parser.scm | 244 +++++++++++++++-------------------
 3 files changed, 225 insertions(+), 256 deletions(-)

diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index f86de57cc..7e24dad97 100644
--- a/src/runtime/mit-syntax.scm
+++ b/src/runtime/mit-syntax.scm
@@ -78,37 +78,42 @@ USA.
 	   (seq-item
 	    (map-in-order (lambda (p) (p))
 			  deferred-items)))
-       spar-discard-elt
-       (spar* spar-push-deferred-classified-elt)
+       (spar-elt)
+       (spar* (spar-elt spar-push-deferred-classified))
        spar-match-null))))
 
 (define :if
   (spar-promise->runtime
    (delay
      (spar-call-with-values if-item
-       spar-discard-elt
-       spar-push-classified-elt
-       spar-push-classified-elt
-       (spar-alt spar-push-classified-elt
-		 (spar-push-thunk-value unspecific-item))
+       (spar-elt)
+       (spar-elt spar-push-classified)
+       (spar-elt spar-push-classified)
+       (spar-or (spar-elt spar-push-classified)
+		(spar-push-value unspecific-item))
        spar-match-null))))
 
 (define :quote
   (spar-promise->runtime
    (delay
      (spar-call-with-values constant-item
-       spar-discard-elt
-       (spar-elt (spar-push-mapped-form strip-syntactic-closures))
+       (spar-elt)
+       (spar-elt (spar-push-value strip-syntactic-closures spar-arg:form))
        spar-match-null))))
 
 (define :quote-identifier
   (spar-promise->runtime
    (delay
      (spar-call-with-values quoted-id-item
-       spar-discard-elt
-       (spar-elt (spar-push-mapped-full lookup-identifier))
+       (spar-elt)
+       (spar-elt
+	 (spar-match identifier? spar-arg:form)
+	 (spar-push-value lookup-identifier spar-arg:form spar-arg:senv)
+	 (spar-or (spar-match var-item? spar-arg:value)
+		  (spar-error "Can't quote a keyword identifier:"
+			      spar-arg:form)))
        spar-match-null))))
-
+
 (define :set!
   (spar-promise->runtime
    (delay
@@ -119,14 +124,17 @@ USA.
 	       (access-assignment-item (access-item-name lhs-item)
 				       (access-item-env lhs-item)
 				       rhs-item)))
-       spar-discard-elt
-       spar-push-classified-elt
-       (spar-match-value
-	(lambda (lhs-item)
-	  (or (var-item? lhs-item)
-	      (access-item? lhs-item))))
-       (spar-alt spar-push-classified-elt
-		 (spar-push-thunk-value unassigned-item))
+       (spar-elt)
+       (spar-elt
+	 spar-push-classified
+	 (spar-or (spar-match (lambda (lhs-item)
+				(or (var-item? lhs-item)
+				    (access-item? lhs-item)))
+			      spar-arg:value)
+		  (spar-error "Variable required in this context:"
+			      spar-arg:form)))
+       (spar-or (spar-elt spar-push-classified)
+		(spar-push-value unassigned-item))
        spar-match-null))))
 
 ;; TODO: this is a classifier rather than a macro because it uses the
@@ -137,8 +145,16 @@ USA.
   (spar-promise->runtime
    (delay
      (spar-encapsulate-values or-item
-       spar-discard-elt
-       (spar* spar-push-classified-elt)
+       (spar-elt)
+       (spar* (spar-elt spar-push-classified))
+       spar-match-null))))
+
+(define :delay
+  (spar-promise->runtime
+   (delay
+     (spar-call-with-values delay-item
+       (spar-elt)
+       (spar-elt spar-push-deferred-classified)
        spar-match-null))))
 
 ;;;; Definitions
@@ -147,11 +163,11 @@ USA.
   (spar-promise->keyword
    (delay
      (spar-call-with-values defn-item
-       spar-discard-elt
+       (spar-elt)
        (spar-elt
-	 (spar-match-form identifier?)
-	 (spar-push-mapped-full bind-variable))
-       spar-push-classified-elt
+	 (spar-match identifier? spar-arg:form)
+	 (spar-push-value bind-variable spar-arg:form spar-arg:senv))
+       (spar-elt spar-push-classified)
        spar-match-null))))
 
 (define :define-syntax
@@ -170,11 +186,14 @@ USA.
 		      (senv-top-level? senv))
 		 (syntax-defn-item id (keyword-item-expr item))
 		 (seq-item '()))))
-       spar-discard-elt
-       spar-push-id-elt
-       spar-push-senv
-       spar-push-classified-elt
-       (spar-match-value keyword-item?)
+       (spar-elt)
+       (spar-elt spar-push-id)
+       (spar-push spar-arg:senv)
+       (spar-elt
+	 spar-push-classified
+	 (spar-or (spar-match keyword-item? spar-arg:value)
+		  (spar-error "Keyword binding value must be a keyword:"
+			      spar-arg:form)))
        spar-match-null))))
 
 ;;;; Lambdas
@@ -185,11 +204,11 @@ USA.
      (spar-call-with-values
 	 (lambda (bvl body senv)
 	   (assemble-lambda-item scode-lambda-name:unnamed bvl body senv))
-       spar-discard-elt
-       (spar-elt (spar-match-form mit-lambda-list?)
-		 spar-push-form)
-       spar-push-body
-       spar-push-senv))))
+       (spar-elt)
+       (spar-elt
+	 (spar-match mit-lambda-list? spar-arg:form)
+	 (spar-push spar-arg:form))
+       spar-push-body))))
 
 (define :named-lambda
   (spar-promise->runtime
@@ -197,12 +216,12 @@ USA.
      (spar-call-with-values
 	 (lambda (name bvl body senv)
 	   (assemble-lambda-item (identifier->symbol name) bvl body senv))
-       spar-discard-elt
-       (spar-elt spar-push-id-elt
-		 (spar-match-form mit-lambda-list?)
-		 spar-push-form)
-       spar-push-body
-       spar-push-senv))))
+       (spar-elt)
+       (spar-elt
+	 (spar-elt spar-push-id)
+	 (spar-match mit-lambda-list? spar-arg:form)
+	 (spar-push spar-arg:form))
+       spar-push-body))))
 
 (define (assemble-lambda-item name bvl body senv)
   (let ((frame-senv (make-internal-senv senv)))
@@ -212,14 +231,6 @@ USA.
 				      bvl)
 		 (lambda ()
 		   (body-item (body frame-senv))))))
-
-(define :delay
-  (spar-promise->runtime
-   (delay
-     (spar-call-with-values delay-item
-       spar-discard-elt
-       spar-push-deferred-classified-elt
-       spar-match-null))))
 
 ;;;; LET-like
 
@@ -236,17 +247,16 @@ USA.
 	     (let-item ids
 		       (map cdr bindings)
 		       (body-item (body frame-senv)))))
-       spar-discard-elt
+       (spar-elt)
        (spar-elt
 	 (spar-push-values
 	   (spar*
 	     (spar-call-with-values cons
-	       (spar-elt spar-push-id-elt
-			 spar-push-classified-elt
+	       (spar-elt (spar-elt spar-push-id)
+			 (spar-elt spar-push-classified)
 			 spar-match-null))))
 	 spar-match-null)
-       spar-push-body
-       spar-push-senv))))
+       spar-push-body))))
 
 (define spar-promise:let-syntax
   (delay
@@ -257,17 +267,16 @@ USA.
 			(bind-keyword (car binding) frame-senv (cdr binding)))
 		      bindings)
 	    (seq-item (body frame-senv))))
-      spar-discard-elt
+      (spar-elt)
       (spar-elt
-	 (spar-push-values
-	   (spar*
-	     (spar-call-with-values cons
-	       (spar-elt spar-push-id-elt
-			 spar-push-classified-elt
-			 spar-match-null))))
-	 spar-match-null)
-       spar-push-body
-       spar-push-senv)))
+	(spar-push-values
+	 (spar*
+	   (spar-call-with-values cons
+	     (spar-elt (spar-elt spar-push-id)
+		       (spar-elt spar-push-classified)
+		       spar-match-null))))
+	spar-match-null)
+       spar-push-body)))
 
 (define :let-syntax
   (spar-promise->runtime spar-promise:let-syntax))
@@ -292,17 +301,16 @@ USA.
 			     ((cdr binding) frame-senv))
 			   bindings))
 	    (seq-item (body frame-senv))))
-      spar-discard-elt
+      (spar-elt)
       (spar-elt
 	 (spar-push-values
 	   (spar*
 	     (spar-call-with-values cons
-	       (spar-elt spar-push-id-elt
-			 spar-push-open-classified-elt
+	       (spar-elt (spar-elt spar-push-id)
+			 (spar-elt spar-push-open-classified)
 			 spar-match-null))))
 	 spar-match-null)
-       spar-push-body
-       spar-push-senv))))
+       spar-push-body))))
 
 ;;;; MIT-specific syntax
 
@@ -316,9 +324,9 @@ USA.
   (spar-promise->keyword
    (delay
      (spar-call-with-values access-item
-       spar-discard-elt
-       spar-push-id-elt
-       spar-push-classified-elt
+       (spar-elt)
+       (spar-elt spar-push-id)
+       (spar-elt spar-push-classified)
        spar-match-null))))
 
 (define-item-compiler access-item?
@@ -330,34 +338,36 @@ USA.
   (spar-promise->runtime
    (delay
      (spar-seq
-       (spar-match-senv senv-top-level?)
-       spar-discard-elt
+       (spar-or (spar-match senv-top-level? spar-arg:senv)
+		(spar-error "This form allowed only at top level:"
+			    spar-arg:form spar-arg:senv))
+       (spar-elt)
        spar-match-null
-       (spar-push-thunk-value the-environment-item)))))
+       (spar-push-value the-environment-item)))))
 
 (define keyword:unspecific
   (spar-promise->keyword
    (delay
      (spar-seq
-       spar-discard-elt
+       (spar-elt)
        spar-match-null
-       (spar-push-thunk-value unspecific-item)))))
+       (spar-push-value unspecific-item)))))
 
 (define keyword:unassigned
   (spar-promise->keyword
    (delay
      (spar-seq
-       spar-discard-elt
+       (spar-elt)
        spar-match-null
-       (spar-push-thunk-value unassigned-item)))))
-
+       (spar-push-value unassigned-item)))))
+
 ;;;; Declarations
 
 (define :declare
   (spar-promise->runtime
    (delay
      (spar-call-with-values
-	 (lambda (decls senv hist)
+	 (lambda (senv hist decls)
 	   (decl-item
 	    (lambda ()
 	      (smap (lambda (decl hist)
@@ -368,19 +378,19 @@ USA.
 				    decl))
 		    decls
 		    (hist-cadr hist)))))
-       spar-discard-elt
+       (spar-elt)
+       (spar-push spar-arg:senv)
+       (spar-push spar-arg:hist)
        (spar-push-values
 	(spar*
 	  (spar-elt
-	    (spar-match-form
-	     (lambda (form)
-	       (and (pair? form)
-		    (identifier? (car form))
-		    (list? (cdr form)))))
-	    spar-push-form)))
-       spar-match-null
-       spar-push-senv
-       spar-push-hist))))
+	    (spar-match (lambda (form)
+			  (and (pair? form)
+			       (identifier? (car form))
+			       (list? (cdr form))))
+			spar-arg:form)
+	    (spar-push spar-arg:form))))
+       spar-match-null))))
 
 (define (classify-id id senv hist)
   (let ((item (classify-form id senv hist)))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 99c0853c4..048f51eb1 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4544,35 +4544,31 @@ USA.
   (export ()
 	  spar*
 	  spar+
-	  spar-alt
 	  spar-append-map-values
+	  spar-arg:form
+	  spar-arg:hist
+	  spar-arg:senv
+	  spar-arg:value
+	  spar-arg:values
 	  spar-call-with-values
-	  spar-discard-elt
 	  spar-discard-form
-	  spar-encapsulate-values
 	  spar-elt
+	  spar-encapsulate-values
+	  spar-error
 	  spar-fail
 	  spar-filter-map-values
-	  spar-push-id-elt
-	  spar-push-id-elt=
 	  spar-map-values
-	  spar-match-form
-	  spar-match-full
+	  spar-match
 	  spar-match-null
-	  spar-match-senv
-	  spar-match-value
 	  spar-opt
+	  spar-or
+	  spar-push
 	  spar-push-body
-	  spar-push-closed-elt
-	  spar-push-closed-form
-	  spar-push-datum
-	  spar-push-elt
-	  spar-push-form
-	  spar-push-hist
-	  spar-push-mapped-form
-	  spar-push-mapped-full
-	  spar-push-senv
-	  spar-push-thunk-value
+	  spar-push-closed
+	  spar-push-id
+	  spar-push-id=
+	  spar-push-partially-closed
+	  spar-push-value
 	  spar-push-values
 	  spar-repeat
 	  spar-seq
@@ -4581,12 +4577,9 @@ USA.
 	  spar-with-mapped-senv)
   (export (runtime syntax)
 	  spar->classifier
-	  spar-push-classified-elt
-	  spar-push-classified-form
-	  spar-push-deferred-classified-elt
-	  spar-push-deferred-classified-form
-	  spar-push-open-classified-elt
-	  spar-push-open-classified-form))
+	  spar-push-classified
+	  spar-push-deferred-classified
+	  spar-push-open-classified))
 
 (define-package (runtime syntax rename)
   (files "syntax-rename")
diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm
index 71fbf430a..13625dc32 100644
--- a/src/runtime/syntax-parser.scm
+++ b/src/runtime/syntax-parser.scm
@@ -145,89 +145,60 @@ USA.
 
 ;;;; Primitives
 
-(define (spar-match-form predicate)
+(define (%subst-args input senv output args)
+  (map (lambda (arg)
+	 (%subst-arg input senv output arg))
+       args))
+
+(define (%subst-arg input senv output arg)
+  (cond ((eq? arg spar-arg:form) (%input-form input))
+	((eq? arg spar-arg:hist) (%input-hist input))
+	((eq? arg spar-arg:senv) senv)
+	((eq? arg spar-arg:value) (%output-top output))
+	((eq? arg spar-arg:values) (%output-all output))
+	(else arg)))
+
+(define-deferred spar-arg:form (string->uninterned-symbol ".form."))
+(define-deferred spar-arg:hist (string->uninterned-symbol ".hist."))
+(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."))
+
+(define (spar-match predicate . args)
   (lambda (input senv output success failure)
-    (if (predicate (%input-form input))
+    (if (apply predicate (%subst-args input senv output args))
 	(success input senv output failure)
 	(failure))))
 
-(define (spar-match-senv predicate)
-  (lambda (input senv output success failure)
-    (if (predicate senv)
-	(success input senv output failure)
-	(failure))))
-
-(define (spar-match-full predicate)
-  (lambda (input senv output success failure)
-    (if (predicate (%input-form input) senv)
-	(success input senv output failure)
-	(failure))))
-
-(define (spar-match-value predicate)
-  (lambda (input senv output success failure)
-    (if (predicate (%output-top output))
-	(success input senv output failure)
-	(failure))))
-
-(define (spar-discard-form input senv output success failure)
-  (declare (ignore input))
-  (success (%null-input) senv output failure))
-
-(define (spar-push-form input senv output success failure)
-  (success (%null-input)
-	   senv
-	   (%output-push output (%input-form input))
-	   failure))
-
-(define (spar-push-hist input senv output success failure)
-  (success (%null-input)
-	   senv
-	   (%output-push output (%input-hist input))
-	   failure))
-
-(define (spar-push-senv input senv output success failure)
-  (success input
-	   senv
-	   (%output-push output senv)
-	   failure))
-
-(define (spar-push-datum object)
+(define (spar-push . args)
   (lambda (input senv output success failure)
     (success input
 	     senv
-	     (%output-push output object)
+	     (%output-push-all output (%subst-args input senv output args))
 	     failure)))
 
-(define (spar-push-thunk-value procedure)
+(define (spar-push-value procedure . args)
   (lambda (input senv output success failure)
     (success input
 	     senv
-	     (%output-push output (procedure))
-	     failure)))
-
-(define (spar-push-mapped-form procedure)
-  (lambda (input senv output success failure)
-    (success (%null-input)
-	     senv
-	     (%output-push output (procedure (%input-form input)))
+	     (%output-push output
+			   (apply procedure
+				  (%subst-args input senv output args)))
 	     failure)))
 
-(define (spar-push-mapped-full procedure)
+(define (spar-error message . irritants)
   (lambda (input senv output success failure)
-    (success (%null-input)
-	     senv
-	     (%output-push output (procedure (%input-form input) senv))
-	     failure)))
+    (declare (ignore success failure))
+    (apply serror
+	   (%input-form input)
+	   senv
+	   (%input-hist input)
+	   message
+	   (%subst-args input senv output irritants))))
 
-(define (%push-classified procedure)
-  (lambda (input senv output success failure)
-    (success (%null-input)
-	     senv
-	     (%output-push output
-			   (procedure (%input-form input)
-				      senv
-				      (%input-hist input)))
-	     failure)))
+(define (spar-discard-form input senv output success failure)
+  (declare (ignore input))
+  (success (%null-input) senv output failure))
 
 ;;;; Repeat combinators
 
@@ -322,12 +293,12 @@ USA.
 	  (s2 input* senv* output* success failure*))
 	failure)))
 
-(define (spar-alt . spars)
+(define (spar-or . spars)
   (cond ((not (pair? spars)) spar-fail)
         ((not (pair? (cdr spars))) (car spars))
-        (else (reduce-right %alt-combiner #f spars))))
+        (else (reduce-right %or-combiner #f spars))))
 
-(define (%alt-combiner s1 s2)
+(define (%or-combiner s1 s2)
   (lambda (input senv output success failure)
     (s1 input senv output success
 	(lambda ()
@@ -355,14 +326,8 @@ USA.
 		failure)
 	  (failure)))))
 
-(define spar-discard-elt
-  (spar-elt spar-discard-form))
-
-(define spar-match-null
-  (spar-match-form null?))
-
-(define spar-push-elt
-  (spar-elt spar-push-form))
+(define-deferred spar-match-null
+  (spar-match null? spar-arg:form))
 
 ;;;; Environment combinators
 
@@ -377,58 +342,57 @@ USA.
 	      (success input* senv output* failure*))
 	    failure))))
 
-(define spar-push-closed-form
-  (spar-push-mapped-full
-   (lambda (form senv)
-     (make-syntactic-closure senv '() form))))
-
-(define spar-push-closed-elt
-  (spar-elt spar-push-closed-form))
-
-(define spar-push-partially-closed-form
-  (spar-push-mapped-full
-   (lambda (form senv)
-     (lambda (free)
-       (make-syntactic-closure senv free form)))))
-
-(define spar-push-partially-closed-elt
-  (spar-elt spar-push-partially-closed-form))
-
-(define-deferred spar-push-classified-form
-  (%push-classified classify-form))
-
-(define-deferred spar-push-classified-elt
-  (spar-elt spar-push-classified-form))
-
-(define spar-push-deferred-classified-form
-  (%push-classified
-   (lambda (form senv hist)
-     (lambda ()
-       (classify-form form senv hist)))))
-
-(define spar-push-deferred-classified-elt
-  (spar-elt spar-push-deferred-classified-form))
-
-(define spar-push-open-classified-form
-  (%push-classified
-   (lambda (form senv hist)
-     (declare (ignore senv))
-     (lambda (senv*)
-       (classify-form form senv* hist)))))
-
-(define spar-push-open-classified-elt
-  (spar-elt spar-push-open-classified-form))
-
-(define-deferred spar-push-id-elt
-  (spar-elt (spar-match-form identifier?)
-	    spar-push-form))
-
-(define (spar-push-id-elt= id)
-  (spar-elt (spar-match-full
-	     (lambda (form senv)
-	       (and (identifier? form)
-		    (identifier=? senv form senv id))))
-	    spar-push-form))
+(define-deferred spar-push-closed
+  (spar-push-value make-syntactic-closure
+		   spar-arg:senv
+		   '()
+		   spar-arg:form))
+
+(define-deferred spar-push-partially-closed
+  (spar-push-value (lambda (senv form)
+		     (lambda (free)
+		       (make-syntactic-closure senv free form)))
+		   spar-arg:senv
+		   spar-arg:form))
+
+(define-deferred spar-push-classified
+  (spar-push-value classify-form
+		   spar-arg:form
+		   spar-arg:senv
+		   spar-arg:hist))
+
+(define-deferred spar-push-deferred-classified
+  (spar-push-value (lambda (form senv hist)
+		     (lambda ()
+		       (classify-form form senv hist)))
+		   spar-arg:form
+		   spar-arg:senv
+		   spar-arg:hist))
+
+(define-deferred spar-push-open-classified
+  (spar-push-value (lambda (form senv hist)
+		     (declare (ignore senv))
+		     (lambda (senv*)
+		       (classify-form form senv* hist)))
+		   spar-arg:form
+		   spar-arg:senv
+		   spar-arg:hist))
+
+(define-deferred spar-push-id
+  (spar-seq
+    (spar-match identifier? spar-arg:form)
+    (spar-push spar-arg:form)
+    spar-discard-form))
+
+(define (spar-push-id= id)
+  (spar-seq
+    (spar-match (lambda (form senv)
+		  (and (identifier? form)
+		       (identifier=? senv form senv id)))
+		spar-arg:form
+		spar-arg:senv)
+    (spar-push spar-arg:form)
+    spar-discard-form))
 
 ;;;; Value combinators
 
@@ -478,12 +442,14 @@ USA.
 		       failure*))
 	    failure))))
 
-(define spar-push-body
-  (spar-encapsulate-values
-      (lambda (elts)
-	(lambda (frame-senv)
-	  (let ((body-senv (make-internal-senv frame-senv)))
-	    (map-in-order (lambda (elt) (elt body-senv))
-			  elts))))
-    (spar+ spar-push-open-classified-elt)
-    spar-match-null))
\ No newline at end of file
+(define-deferred spar-push-body
+  (spar-seq
+    (spar-encapsulate-values
+	(lambda (elts)
+	  (lambda (frame-senv)
+	    (let ((body-senv (make-internal-senv frame-senv)))
+	      (map-in-order (lambda (elt) (elt body-senv))
+			    elts))))
+      (spar+ (spar-elt spar-push-open-classified))
+      spar-match-null)
+    (spar-push spar-arg:senv)))
\ No newline at end of file
-- 
2.25.1