src/parser/floc-proto.lisp: Associate restarts when resignalling.

`with-default-error-location*' catches conditions and maybe resignals
versions of them with error location information.  But the new
conditions don't have the same restarts associated with them, so
functions like `muffle-warning' will fail.

Fixing this is a little fiddly, but a general solution is possible.

diff --git a/src/parser/floc-proto.lisp b/src/parser/floc-proto.lisp
index f645bb1..c4d0804 100644 (file)
--- 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)