From db6c3279edc260e3e301df1c9b082b374cd002c7 Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Thu, 26 May 2016 09:26:09 +0100 Subject: [PATCH] src/parser/floc-proto.lisp, src/utilities.lisp: New `information' condition. For reporting extra information about errors. --- doc/SYMBOLS | 22 +++++++++++++++++++++ doc/misc.tex | 21 ++++++++++++++++++++ doc/parsing.tex | 11 +++++++++++ doc/sod.sty | 1 + src/parser/floc-proto.lisp | 49 +++++++++++++++++++++++++++++++++++++++++++++- src/utilities.lisp | 24 +++++++++++++++++++++++ 6 files changed, 127 insertions(+), 1 deletion(-) diff --git a/doc/SYMBOLS b/doc/SYMBOLS index e903d91..43ed0f2 100644 --- a/doc/SYMBOLS +++ b/doc/SYMBOLS @@ -1579,6 +1579,7 @@ floc-proto.lisp enclosing-condition-with-location class enclosing-condition-with-location-type generic enclosing-error-with-location class + enclosing-information-with-location class enclosing-warning-with-location class error-with-location function class file-location generic class @@ -1586,10 +1587,17 @@ floc-proto.lisp file-location-filename function file-location-line function file-location-p function + info function + info-with-location function + information class + information-with-location class make-condition-with-location function make-file-location function + noted simple-condition-with-location class simple-error-with-location class + simple-information class + simple-information-with-location class simple-warning-with-location class warn-with-location function warning-with-location class @@ -1728,16 +1736,26 @@ cl:t condition-with-location enclosing-condition-with-location [enclosing-condition] enclosing-error-with-location [cl:error] + enclosing-information-with-location [information] enclosing-warning-with-location [cl:warning] error-with-location [cl:error] simple-error-with-location [cl:simple-error] + information-with-location [information] + simple-information-with-location [simple-information] simple-condition-with-location [cl:simple-condition] warning-with-location [cl:warning] simple-warning-with-location [cl:simple-warning] enclosing-condition enclosing-condition-with-location [condition-with-location] enclosing-error-with-location [cl:error] + enclosing-information-with-location [information] enclosing-warning-with-location [cl:warning] + information + enclosing-information-with-location [enclosing-condition-with-location] + information-with-location [condition-with-location] + simple-information-with-location [simple-information] + simple-information [cl:simple-condition] + simple-information-with-location [information-with-location] cl:serious-condition cl:error enclosing-error-with-location [enclosing-condition-with-location] @@ -1749,6 +1767,8 @@ cl:t simple-condition-with-location [condition-with-location] cl:simple-error [cl:error] simple-error-with-location [error-with-location] + simple-information [information] + simple-information-with-location [information-with-location] cl:simple-warning [cl:warning] simple-warning-with-location [warning-with-location] cl:warning @@ -1865,6 +1885,7 @@ enclosing-condition-with-location-type cl:condition cl:error cl:warning + information expand-parser-form t (eql cl:and) t t (eql cl:list) t @@ -2196,6 +2217,7 @@ utilities.lisp default-slot macro define-access-wrapper macro define-on-demand-slot macro + designated-condition function dosequence macro sb-mop:eql-specializer class sb-mop:eql-specializer-object generic diff --git a/doc/misc.tex b/doc/misc.tex index ae1fd2b..2e7b504 100644 --- a/doc/misc.tex +++ b/doc/misc.tex @@ -200,6 +200,13 @@ These symbols are defined in the @|sod-utilities| package. @[[ :read-only @ @]]} \end{describe} +\begin{describe}{fun} + {designated-condition + \=@ @ @ \\ + \>\&key :allow-pointless-arguments + \nlret @} +\end{describe} + \begin{describe}{mac} {default-slot (@ @ @[@@]) \\ \ind @
^*} @@ -223,6 +230,20 @@ These symbols are defined in the @|sod-parser| package. {enclosed-condition @ @> @} \end{describe} +\begin{describe}{cls}{information (condition) \&key} +\end{describe} + +\begin{describe}{cls} + {simple-information (simple-condition information) \\ \ind + \&key :format-control :format-arguments} +\end{describe} + +\begin{describe}{fun}{info @ \&rest @ @> @} +\end{describe} + +\begin{describe}{rst}{noted} +\end{describe} + \begin{describe}{fun}{cerror* @ \&rest @} \end{describe} diff --git a/doc/parsing.tex b/doc/parsing.tex index c3cc003..d0671a2 100644 --- a/doc/parsing.tex +++ b/doc/parsing.tex @@ -95,6 +95,9 @@ consumed any input items. {warning-with-location (condition-with-location warning) \\ \> \&key :location} \dhead{cls} + {information-with-location (condition-with-location information) \\ \> + \&key :location} + \dhead{cls} {enclosing-error-with-location (enclosing-error-with-location error) \\ \> \&key :condition :location} @@ -103,6 +106,10 @@ consumed any input items. (enclosing-condition-with-location warning) \\ \> \&key :condition :location} \dhead{cls} + {enclosing-information-with-location + (enclosing-condition-with-location information) \\ \> + \&key :condition :location} + \dhead{cls} {simple-condition-with-location (condition-with-location simple-condition) \\ \> \&key :format-control :format-arguments :location} @@ -113,6 +120,10 @@ consumed any input items. \dhead{cls} {simple-warning-with-location (warning-with-location simple-warning) \\ \> + \&key :format-control :format-arguments :location} + \dhead{cls} + {simple-information-with-location + (information-with-location simple-information) \\ \> \&key :format-control :format-arguments :location}} \end{describe*} diff --git a/doc/sod.sty b/doc/sod.sty index f1ba880..d77c038 100644 --- a/doc/sod.sty +++ b/doc/sod.sty @@ -186,6 +186,7 @@ \definedescribecategory{be-meth}{before method} \definedescribecategory{af-meth}{after method} \definedescribecategory{cls}{class} +\definedescribecategory{rst}{restart} \definedescribecategory{ty}{type} \definedescribecategory{type}{type} \definedescribecategory{mac}{macro} diff --git a/src/parser/floc-proto.lisp b/src/parser/floc-proto.lisp index e3dca32..f65ed73 100644 --- a/src/parser/floc-proto.lisp +++ b/src/parser/floc-proto.lisp @@ -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,6 +130,26 @@ (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. @@ -128,6 +162,7 @@ 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) @@ -196,6 +231,13 @@ '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. @@ -306,7 +348,12 @@ (file-location warning) warning) (incf warnings) - (invoke-restart 'muffle-warning)))) + (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))) diff --git a/src/utilities.lisp b/src/utilities.lisp index 1d58fa3..72423fd 100644 --- a/src/utilities.lisp +++ b/src/utilities.lisp @@ -833,6 +833,30 @@ (setf (,to object) value)))))) ;;;-------------------------------------------------------------------------- +;;; Condition and error utilities. + +(export 'designated-condition) +(defun designated-condition (default-type datum arguments + &key allow-pointless-arguments) + "Return the condition designated by DATUM and ARGUMENTS. + + DATUM and ARGUMENTS together are a `condition designator' of (some + supertype of) DEFAULT-TYPE; return the condition so designated." + (typecase datum + (condition + (unless (or allow-pointless-arguments (null arguments)) + (error "Argument list provided with specific condition")) + datum) + (symbol + (apply #'make-condition datum arguments)) + ((or string function) + (make-condition default-type + :format-control datum + :format-arguments arguments)) + (t + (error "Unexpected condition designator datum ~S" datum)))) + +;;;-------------------------------------------------------------------------- ;;; CLOS hacking. (export 'default-slot) -- 2.11.0