X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/40d95de71fca4c3b7b145d5ba73d1420e8854673..6eaf78e4c0b4728b464999806f5c109ab32e706b:/src/parser/floc-proto.lisp diff --git a/src/parser/floc-proto.lisp b/src/parser/floc-proto.lisp index f645bb1..0ee952d 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) @@ -83,10 +67,6 @@ (condition-with-location enclosing-condition) ()) -(export 'information) -(define-condition information (condition) - ()) - (export 'error-with-location) (define-condition error-with-location (condition-with-location error) ()) @@ -130,26 +110,6 @@ (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) @@ -243,31 +203,14 @@ '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)) @@ -275,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-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)