Change spars to set up error context when calling out to procedures.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 45b12b488e738c31b31e690feb29d976c002cc0f..58707f74f45f5ea1faa01d82e72e37cccde9d063 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4449,6 +4449,8 @@ USA.
          subform-select)
   (export (runtime syntax low)
          reclassify
+         with-error-context)
+  (export (runtime syntax parser)
          with-error-context))
 
 (define-package (runtime syntax low)

diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm
index 7bf2f74709858465ddf2d904937f4ec73436ac7a..64f8fa1f7f67e50846eee9f585682b8907ac91aa 100644 (file)
--- a/src/runtime/syntax-parser.scm
+++ b/src/runtime/syntax-parser.scm
@@ -202,7 +202,8 @@ USA.
     (success input
             senv
             (%output-push output
-                          (apply procedure
+                          (apply %call-out input senv
+                                 procedure
                                  (%subst-args input senv output args)))
             failure)))
 
@@ -372,35 +373,38 @@ USA.
   (let ((spar (%and spars)))
     (lambda (input senv output success failure)
       (spar input
-           (procedure senv)
+           (%call-out input senv procedure senv)
            output
            (lambda (input* senv* output* failure*)
              (declare (ignore senv*))
              (success input* senv output* failure*))
            failure))))
 
+(define (%push-classified classifier)
+  (lambda (input senv output success failure)
+    (success input
+            senv
+            (%output-push output
+                          (classifier (%input-form input)
+                                      senv
+                                      (%input-hist input)))
+            failure)))
+
 (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))
+  (%push-classified classify-form))
+
+(define spar-push-deferred-classified
+  (%push-classified
+   (lambda (form senv hist)
+     (lambda ()
+       (classify-form form senv hist)))))
+
+(define spar-push-open-classified
+  (%push-classified
+   (lambda (form senv hist)
+     (declare (ignore senv))
+     (lambda (senv*)
+       (classify-form form senv* hist)))))
 
 (define-deferred spar-push-body
   (spar-and
@@ -453,9 +457,14 @@ USA.
            (lambda (input* senv* output* failure*)
              (success input*
                       senv*
-                      (procedure output output*)
+                      (%call-out input senv procedure output output*)
                       failure*))
            failure))))
+
+(define (%call-out input senv procedure . args)
+  (with-error-context (%input-form input) senv (%input-hist input)
+    (lambda ()
+      (apply procedure args))))
 \f
 ;;;; Shorthand