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
`file-location designator'.")
(: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.
(define-condition warning-with-location (condition-with-location warning)
())
+(export 'information-with-location)
+(define-condition information-with-location
+ (condition-with-location information)
+ ())
+
(export 'enclosing-error-with-location)
(define-condition enclosing-error-with-location
(enclosing-condition-with-location error)
(enclosing-condition-with-location warning)
())
+(export 'enclosing-information-with-location)
+(define-condition enclosing-information-with-location
+ (enclosing-condition-with-location information)
+ ())
+
(export 'simple-condition-with-location)
(define-condition simple-condition-with-location
(condition-with-location simple-condition)
(warning-with-location simple-warning)
())
+(export 'simple-information-with-location)
+(define-condition simple-information-with-location
+ (information-with-location simple-information)
+ ())
+
;;;--------------------------------------------------------------------------
;;; Reporting errors.
+(export 'enclosing-condition-with-location-type)
+(defgeneric enclosing-condition-with-location-type (condition)
+ (:documentation
+ "Return a class suitable for attaching location information to CONDITION.
+
+ Specifically, return the name of a subclass of `enclosing-condition-
+ with-location' suitable to enclose CONDITION.")
+ (:method ((condition error)) 'enclosing-error-with-location)
+ (:method ((condition warning)) 'enclosing-warning-with-location)
+ (:method ((condition information)) 'enclosing-information-with-location)
+ (:method ((condition condition)) 'enclosing-condition-with-location))
+
(export 'make-condition-with-location)
(defun make-condition-with-location (default-type floc datum &rest arguments)
"Construct a `condition-with-location' given a condition designator.
if the condition was a subtype of ERROR or WARNING then the resulting
condition will also be subtype of ERROR or WARNING as appropriate."
- (labels ((wrap (condition)
+ (labels ((check-no-args ()
+ (unless (null arguments)
+ (error "Argument list provided with specific condition")))
+ (wrap (condition)
(make-condition
- (etypecase condition
- (error 'enclosing-error-with-location)
- (warning 'enclosing-warning-with-location)
- (condition 'enclosing-condition-with-location))
+ (enclosing-condition-with-location-type condition)
:condition condition
:location (file-location floc)))
(make (type &rest initargs)
:location (file-location floc)
initargs)
(wrap (apply #'make-condition type initargs)))))
- (etypecase datum
- (condition-with-location datum)
- (condition (wrap datum))
- (symbol (apply #'make arguments))
+ (typecase datum
+ (condition-with-location (check-no-args) datum)
+ (condition (check-no-args) (wrap datum))
+ (symbol (apply #'make datum arguments))
((or string function) (make default-type
:format-control datum
- :format-arguments arguments)))))
+ :format-arguments arguments))
+ (t (error "Unexpected condition designator datum ~S" datum)))))
(export 'error-with-location)
(defun error-with-location (floc datum &rest arguments)
'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 'info-with-location)
+(defun info-with-location (floc datum &rest arguments)
+ "Report some information with attached location information."
+ (info (apply #'make-condition-with-location
+ 'simple-information-with-location
+ floc datum arguments)))
(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)
`(with-default-error-location* ,floc (lambda () ,@body)))
+;;;--------------------------------------------------------------------------
+;;; Custom errors for parsers.
+
+;; Resolve dependency cycle.
+(export '(parser-error-expected parser-error-found))
+(defgeneric parser-error-expected (condition))
+(defgeneric parser-error-found (condition))
+
+(export 'report-parser-error)
+(defun report-parser-error (error stream show-expected show-found)
+ (format stream "~:[Unexpected~;~
+ Expected ~:*~{~#[~;~A~;~A or ~A~:;~
+ ~@{~A, ~#[~;or ~A~]~}~]~} but found~] ~
+ ~A"
+ (mapcar show-expected (parser-error-expected error))
+ (funcall show-found (parser-error-found error))))
+
+(export 'parser-error)
+(define-condition parser-error (error)
+ ((expected :initarg :expected :reader parser-error-expected :type list)
+ (found :initarg :found :reader parser-error-found :type t))
+ (:documentation "Standard error from a parser.
+
+ Supports the usual kinds of parser failure, where the parser was expecting
+ some kinds of things but found something else.")
+ (:report (lambda (error stream)
+ (report-parser-error error stream
+ #'prin1-to-string #'prin1-to-string))))
+
+(export '(base-lexer-error simple-lexer-error))
+(define-condition base-lexer-error (error-with-location) ())
+(define-condition simple-lexer-error
+ (base-lexer-error simple-error-with-location)
+ ())
+
+(export '(base-syntax-error simple-syntax-error))
+(define-condition base-syntax-error (error-with-location) ())
+(define-condition simple-syntax-error
+ (base-syntax-error simple-error-with-location)
+ ())
+
;;;--------------------------------------------------------------------------
;;; Front-end error reporting.
+(export 'classify-condition)
+(defgeneric classify-condition (condition)
+ (:method ((condition error)) "error")
+ (:method ((condition base-lexer-error)) "lexical error")
+ (:method ((condition base-syntax-error)) "syntax error")
+ (:method ((condition warning)) "warning")
+ (:method ((condition information)) "note"))
+
(defun count-and-report-errors* (thunk)
"Invoke THUNK in a dynamic environment which traps and reports errors.
(warnings 0))
(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)))
+ (flet ((report (condition &optional indicator)
+ (let ((*print-pretty* nil))
+ (format *error-output*
+ "~&~A: ~@[~A ~]~A: ~A~%"
+ (file-location condition)
+ indicator (classify-condition condition)
+ condition))))
+ (handler-bind
+ ((error (lambda (error)
+ (let ((fatal (eq (find-restart 'continue error)
+ our-continue-restart)))
+ (report error (and fatal "fatal"))
+ (incf errors)
+ (if fatal
+ (return-from count-and-report-errors*
+ (values nil errors warnings))
+ (continue error)))))
+ (warning (lambda (warning)
+ (report warning)
+ (incf warnings)
+ (muffle-warning warning)))
+ (information (lambda (info)
+ (report info)
+ (noted info))))
+ (values (funcall thunk)
+ errors
+ warnings))))
(continue ()
:report (lambda (stream) (write-string "Exit to top-level" stream))
(values nil errors warnings)))))
~mdw / sod / blobdiff