-(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))))