;;;----- Licensing notice ---------------------------------------------------
;;;
-;;; This file is part of the Sensble Object Design, an object system for C.
+;;; This file is part of the Sensible Object Design, an object system for C.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
file-location-filename file-location-line file-location-column))
(defstruct (file-location
(:constructor make-file-location
- (%filename 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
- ERROR-FILE-LOCATION."
+ Construct using `make-file-location'; the main useful function is
+ `error-file-location'."
(filename nil :type (or string null) :read-only t)
(line nil :type (or fixnum null) :read-only t)
(column nil :type (or fixnum null) :read-only t))
(defgeneric file-location (thing)
(:documentation
- "Convert THING into a FILE-LOCATION, if possible.
+ "Convert THING into a `file-location', if possible.
- A THING which can be converted into a FILE-LOCATION is termed a
+ A THING which can be converted into a `file-location' is termed a
`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.
(export 'condition-with-location)
(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.
+ "Construct a `condition-with-location' given a condition designator.
- The returned condition will always be a CONDITION-WITH-LOCATION. The
+ The returned condition will always be a `condition-with-location'. The
process consists of two stages. In the first stage, a condition is
constructed from the condition designator DATUM and ARGUMENTS with default
type DEFAULT-TYPE (a symbol). The precise behaviour depends on DATUM:
* If DATUM is a symbol, then it must name a condition type. An instance
of this class is constructed using ARGUMENTS as initargs, i.e., as
if (apply #'make-condition ARGUMENTS); if the type is a subtype of
- CONDITION-WITH-LOCATION then FLOC is attached as the location.
+ `condition-with-location' then FLOC is attached as the location.
* If DATUM is a format control (i.e., a string or function), then the
condition is constructed as if, instead, DEFAULT-TYPE had been
:format-arguments ARGUMENTS) supplied as ARGUMENTS.
In the second stage, the condition constructed by the first stage is
- converted into a CONDITION-WITH-LOCATION. If the condition already has
- type CONDITION-WITH-LOCATION then it is returned as is. Otherwise it is
- wrapped in an appropriate subtype of ENCLOSING-CONDITION-WITH-LOCATION:
+ converted into a `condition-with-location'. If the condition already has
+ type `condition-with-location' then it is returned as is. Otherwise it is
+ wrapped in an appropriate subtype of `enclosing-condition-with-location':
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)))
+(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."
- (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))
+ (promiscuous-cerror continue-string
+ (apply #'make-condition-with-location
+ 'simple-error-with-location
+ floc datum arguments)))
(export 'cerror*-with-location)
(defun cerror*-with-location (floc datum &rest 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-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)
attaches FLOC to errors (and other conditions) which do not have file
location information attached to them already.
- If a condition other than a CONDITION-WITH-LOCATION is signalled during
+ If a condition other than a `condition-with-location' is signalled during
the evaluation of the BODY, then an instance of an appropriate subcalass
- of ENCLOSING-CONDITION-WITH-LOCATION is constructed, enclosing the
+ of `enclosing-condition-with-location' is constructed, enclosing the
original condition, and signalled. In particular, if the original
condition was a subtype of ERROR or WARNING, then the new condition will
also be a subtype of ERROR or WARNING as appropriate.
- The FLOC argument is coerced to a FILE-LOCATION object each time a
+ The FLOC argument is coerced to a `file-location' object each time a
condition is signalled. For example, if FLOC is a lexical analyser object
- which reports its current position in response to FILE-LOCATION, then each
- condition will be reported as arising at the lexer's current position at
- that time, rather than all being reported at the same position.
+ which reports its current position in response to `file-location', then
+ each condition will be reported as arising at the lexer's current position
+ at that time, rather than all being reported at the same position.
If the new enclosing condition is not handled, the handler established by
this macro will decline to handle the original condition. Typically,
- however, the new condition will be handled by COUNT-AND-REPORT-ERRORS.
+ however, the new condition will be handled by `count-and-report-errors'.
As a special case, if FLOC is nil, then no special action is taken, and
BODY is simply evaluated, as an implicit progn."
`(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.
- 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)))
+ (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)))))
(export 'count-and-report-errors)
(defmacro count-and-report-errors (() &body body)
The BODY is evaluated. If an error or warning is signalled, it is
reported (using its report function), and counted. Warnings are otherwise
- muffled; continuable errors (i.e., when a CONTINUE restart is defined) are
- continued; non-continuable errors cause an immediate exit from the BODY.
+ muffled; continuable errors (i.e., when a `continue' restart is defined)
+ are continued; non-continuable errors cause an immediate exit from the
+ BODY.
The final value consists of three values: the primary value of the BODY
- (or NIL if a non-continuable error occurred), the number of errors
+ (or nil if a non-continuable error occurred), the number of errors
reported, and the number of warnings reported."
`(count-and-report-errors* (lambda () ,@body)))
~mdw / sod / blobdiff