file-location-filename file-location-line file-location-column))
(defstruct (file-location
(:constructor make-file-location
- (%filename &optional line column
- &aux (filename
- (etypecase %filename
- ((or string null) %filename)
- (pathname (namestring %filename)))))))
+ (%filename
+ &optional line column
+ &aux (filename (etypecase %filename
+ ((or string null) %filename)
+ (pathname (namestring %filename)))))))
"A simple structure containing file location information.
Construct using `make-file-location'; the main useful function is
(:method ((thing file-location)) thing))
;;;--------------------------------------------------------------------------
-;;; Enclosing conditions.
-
-(export '(enclosing-condition enclosed-condition))
-(define-condition enclosing-condition (condition)
- ((%enclosed-condition :initarg :condition :type condition
- :reader enclosed-condition))
- (:documentation
- "A condition which encloses another condition
-
- This is useful if one wants to attach additional information to an
- existing condition. The enclosed condition can be obtained using the
- `enclosed-condition' function.")
- (:report (lambda (condition stream)
- (princ (enclosed-condition condition) stream))))
-
-;;;--------------------------------------------------------------------------
;;; Conditions with location information.
(export 'condition-with-location)
(condition-with-location enclosing-condition)
())
-(export 'information)
-(define-condition information (condition)
- ())
-
(export 'error-with-location)
(define-condition error-with-location (condition-with-location error)
())
(warning-with-location simple-warning)
())
-(export 'simple-information)
-(define-condition simple-information (simple-condition information)
- ())
-
-(export 'info)
-(defun info (datum &rest arguments)
- "Report some useful diagnostic information.
-
- Establish a simple restart named `noted', and signal the condition of type
- `information' designated by DATUM and ARGUMENTS. Return non-nil if the
- restart was invoked, otherwise nil."
- (restart-case
- (signal (designated-condition 'simple-information datum arguments))
- (noted () :report "Noted." t)))
-
-(export 'noted)
-(defun noted (&optional condition)
- "Invoke the `noted' restart, possibly associated with the given CONDITION."
- (invoke-associated-restart 'noted condition))
-
(export 'simple-information-with-location)
(define-condition simple-information-with-location
(information-with-location simple-information)
'simple-information-with-location
floc datum arguments)))
-(defun my-cerror (continue-string datum &rest arguments)
- "Like standard `cerror', but robust against sneaky changes of conditions.
-
- It seems that `cerror' (well, at least the version in SBCL) is careful
- to limit its restart to the specific condition it signalled. But that's
- annoying, because `with-default-error-location' substitutes different
- conditions carrying the error-location information."
- (restart-case (apply #'error datum arguments)
- (continue ()
- :report (lambda (stream)
- (apply #'format stream continue-string datum arguments))
- nil)))
-
(export 'cerror-with-location)
(defun cerror-with-location (floc continue-string datum &rest arguments)
"Report a continuable error with attached location information."
- (my-cerror continue-string
+ (promiscuous-cerror continue-string
(apply #'make-condition-with-location
'simple-error-with-location
floc datum arguments)))
-(export 'cerror*)
-(defun cerror* (datum &rest arguments)
- (apply #'my-cerror "Continue" datum arguments))
-
(export 'cerror*-with-location)
(defun cerror*-with-location (floc datum &rest arguments)
(apply #'cerror-with-location floc "Continue" datum arguments))
;;;--------------------------------------------------------------------------
;;; 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-condition '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)
~mdw / sod / blobdiff