X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/3109662aca9c06495ac22c5c58b46e1c036aca5c..e046c3f65a8f7241889fb9b6005aac21e2aad1a8:/src/parser/floc-proto.lisp diff --git a/src/parser/floc-proto.lisp b/src/parser/floc-proto.lisp index 1a50841..f65ed73 100644 --- a/src/parser/floc-proto.lisp +++ b/src/parser/floc-proto.lisp @@ -7,7 +7,7 @@ ;;;----- 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 @@ -32,7 +32,7 @@ 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) @@ -58,8 +58,8 @@ (export '(enclosing-condition enclosed-condition)) (define-condition enclosing-condition (condition) - ((enclosed-condition :initarg :condition :type condition - :reader enclosed-condition)) + ((%enclosed-condition :initarg :condition :type condition + :reader enclosed-condition)) (:documentation "A condition which encloses another condition @@ -83,6 +83,10 @@ (condition-with-location enclosing-condition) ()) +(export 'information) +(define-condition information (condition) + ()) + (export 'error-with-location) (define-condition error-with-location (condition-with-location error) ()) @@ -91,6 +95,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 +110,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 +130,41 @@ (warning-with-location simple-warning) ()) +(export 'simple-information) +(define-condition simple-information (simple-condition information) + ()) + +(export '(info noted)) +(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 '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 +194,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 +208,14 @@ :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) @@ -184,17 +231,37 @@ '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))) + +(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) @@ -256,31 +323,43 @@ (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))) + (information (lambda (info) + (format *error-output* "~&~A: Info: ~A~%" + (file-location info) + info) + (invoke-restart 'noted)))) + (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)