From fd824f3c157d2258a24ed9e8855ea822ff20d23a Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 25 Mar 2018 17:05:17 -0700
Subject: [PATCH] Change spars to set up error context when calling out to
 procedures.

---
 src/runtime/runtime.pkg       |  2 ++
 src/runtime/syntax-parser.scm | 57 ++++++++++++++++++++---------------
 2 files changed, 35 insertions(+), 24 deletions(-)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 45b12b488..58707f74f 100644
--- 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 7bf2f7470..64f8fa1f7 100644
--- 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))))
 
 ;;;; Shorthand
 
-- 
2.25.1