file-location-filename file-location-line file-location-column))
(defstruct (file-location
(:constructor make-file-location
- (%filename line column
+ (%filename &optional line column
&aux (filename
(etypecase %filename
((or string null) %filename)
'simple-warning-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."
- (cerror continue-string
- (apply #'make-condition-with-location
- 'simple-error-with-location
- floc datum arguments)))
+ (my-cerror continue-string
+ (apply #'make-condition-with-location
+ 'simple-error-with-location
+ floc datum arguments)))
(export 'cerror*)
(defun cerror* (datum &rest arguments)
- (apply #'cerror "Continue" datum arguments))
+ (apply #'my-cerror "Continue" datum arguments))
(export 'cerror*-with-location)
(defun cerror*-with-location (floc datum &rest arguments)
(defun count-and-report-errors* (thunk)
"Invoke THUNK in a dynamic environment which traps and reports errors.
- See the `count-and-report-errors' macro for more detais."
+ See the `count-and-report-errors' macro for more details."
(let ((errors 0)
(warnings 0))
- (handler-bind
- ((error (lambda (error)
- (let ((fatal (not (find-restart 'continue error))))
- (format *error-output* "~&~A: ~:[~;Fatal error: ~]~A~%"
- (file-location error)
- fatal
- error)
- (incf errors)
- (if fatal
- (return-from count-and-report-errors*
- (values nil errors warnings))
- (invoke-restart 'continue)))))
- (warning (lambda (warning)
- (format *error-output* "~&~A: Warning: ~A~%"
- (file-location warning)
- warning)
- (incf warnings)
- (invoke-restart 'muffle-warning))))
- (values (funcall thunk)
- errors
- warnings))))
+ (restart-case
+ (let ((our-continue-restart (find-restart 'continue)))
+ (handler-bind
+ ((error (lambda (error)
+ (let ((fatal (eq (find-restart 'continue error)
+ our-continue-restart)))
+ (format *error-output*
+ "~&~A: ~:[~;Fatal error: ~]~A~%"
+ (file-location error)
+ fatal
+ error)
+ (incf errors)
+ (if fatal
+ (return-from count-and-report-errors*
+ (values nil errors warnings))
+ (invoke-restart 'continue)))))
+ (warning (lambda (warning)
+ (format *error-output* "~&~A: Warning: ~A~%"
+ (file-location warning)
+ warning)
+ (incf warnings)
+ (invoke-restart 'muffle-warning))))
+ (values (funcall thunk)
+ errors
+ warnings)))
+ (continue ()
+ :report (lambda (stream) (write-string "Exit to top-level" stream))
+ (values nil errors warnings)))))
(export 'count-and-report-errors)
(defmacro count-and-report-errors (() &body body)