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