X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/3a774b55edfea441c1715994924c2999e9202143..489173a51e3020f7e0f73208c92ba0a03e21e048:/src/parser/floc-proto.lisp

diff --git a/src/parser/floc-proto.lisp b/src/parser/floc-proto.lisp
index f645bb1..c4d0804 100644
--- a/src/parser/floc-proto.lisp
+++ b/src/parser/floc-proto.lisp
@@ -275,24 +275,38 @@
 ;;;--------------------------------------------------------------------------
 ;;; Stamping errors with location information.
 
-(defun with-default-error-location* (floc thunk)
-  "Invoke THUNK in a dynamic environment which attaches FLOC to errors (and
-   other conditions) which do not have file location information attached to
-   them already.
-
-   See the `with-default-error-location' macro for more details."
-
-  (if floc
-      (handler-bind
-	  ((condition-with-location
-	    (lambda (condition)
-	      (declare (ignore condition))
-	      :decline))
-	   (condition
-	    (lambda (condition)
-	      (signal (make-condition-with-location nil floc condition)))))
-	(funcall thunk))
-      (funcall thunk)))
+(let ((control-condition (make-instance 'condition)))
+  (defun with-default-error-location* (floc thunk)
+    "Invoke THUNK in a dynamic environment which attaches FLOC to errors (and
+     other conditions) which do not have file location information attached
+     to them already.
+
+     See the `with-default-error-location' macro for more details."
+
+    (if floc
+	(handler-bind
+	    ((condition-with-location
+	      (lambda (condition)
+		(declare (ignore condition))
+		:decline))
+	     (condition
+	      (lambda (condition)
+
+		;; The original condition may have restarts associated with
+		;; it.  Find them and associate them with our new condition
+		;; when we signal that.  For added fun, there isn't a
+		;; function to find just the associated restarts, or to find
+		;; out whether a restart is associated, so do this by making
+		;; up a control condition which has never been associated
+		;; with a restart.
+		(let ((enclosing (make-condition-with-location nil floc
+							       condition)))
+		  (with-condition-restarts enclosing
+		      (set-difference (compute-restarts condition)
+				      (compute-restarts control-condition))
+		    (signal enclosing))))))
+	  (funcall thunk))
+	(funcall thunk))))
 
 (export 'with-default-error-location)
 (defmacro with-default-error-location ((floc) &body body)