X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/89ef4001b93c0219096c94125e7e9fdb745d2c97..12949379840101e2d65883f29c5e8f0f6de49e9c:/src/parser/floc-proto.lisp diff --git a/src/parser/floc-proto.lisp b/src/parser/floc-proto.lisp index 484fce0..9eb31d4 100644 --- a/src/parser/floc-proto.lisp +++ b/src/parser/floc-proto.lisp @@ -32,11 +32,11 @@ 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 @@ -54,22 +54,6 @@ (: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) @@ -91,6 +75,11 @@ (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) @@ -101,6 +90,11 @@ (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) @@ -116,9 +110,26 @@ (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. @@ -148,12 +159,12 @@ 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) @@ -162,13 +173,14 @@ :location (file-location floc) initargs) (wrap (apply #'make-condition type initargs))))) - (etypecase datum - (condition-with-location datum) - (condition (wrap datum)) + (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) @@ -184,31 +196,21 @@ '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)) @@ -216,24 +218,38 @@ ;;;-------------------------------------------------------------------------- ;;; 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) @@ -264,8 +280,57 @@ `(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. @@ -275,29 +340,33 @@ (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)))))