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.

diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index f86de57cc0335cb7d99724329baa09cc646ddda3..7e24dad97b233dd70c838d7b50813603ecb6d94f 100644 (file)
--- 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))))
-
+\f
 (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))))
 \f
 ;;;; 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))))
 \f
 ;;;; 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))))
 \f
 ;;;; 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)))))
+\f
 ;;;; 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 99c0853c478fb44924d7a8888502cde5826f2d92..048f51eb1ffe4bb6771d6b4e5d22784fb0b0a24e 100644 (file)
--- 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 71fbf430a2eb2322b45da50b2eb801d959586db4..13625dc328887fb718063b2c197cae9de97b4303 100644 (file)
--- a/src/runtime/syntax-parser.scm
+++ b/src/runtime/syntax-parser.scm
@@ -145,89 +145,60 @@ USA.
 \f
 ;;;; 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))
 \f
 ;;;; 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))))
 \f
-(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))
 \f
 ;;;; 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