3 ;;; Error types and handling utilities
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Simple Object Definition system.
12 ;;; SOD is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 2 of the License, or
15 ;;; (at your option) any later version.
17 ;;; SOD is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with SOD; if not, write to the Free Software Foundation,
24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
28 ;;;--------------------------------------------------------------------------
29 ;;; Enclosing conditions.
31 (define-condition enclosing-condition (condition)
32 ((enclosed-condition :initarg :condition
34 :reader enclosed-condition))
36 "A condition which encloses another condition
38 This is useful if one wants to attach additional information to an
39 existing condition. The enclosed condition can be obtained using the
40 ENCLOSED-CONDITION function.")
41 (:report (lambda (condition stream)
42 (princ (enclosed-condition condition) stream))))
44 ;;;--------------------------------------------------------------------------
45 ;;; Conditions with location information.
47 (define-condition condition-with-location (condition)
48 ((location :initarg :location
52 "A condition which has some location information attached."))
54 (define-condition enclosing-condition-with-location
55 (condition-with-location enclosing-condition)
58 (define-condition error-with-location (condition-with-location error)
61 (define-condition warning-with-location (condition-with-location warning)
64 (define-condition enclosing-error-with-location
65 (enclosing-condition-with-location error)
68 (define-condition enclosing-warning-with-location
69 (enclosing-condition-with-location warning)
72 (define-condition simple-condition-with-location
73 (condition-with-location simple-condition)
76 (define-condition simple-error-with-location
77 (error-with-location simple-error)
80 (define-condition simple-warning-with-location
81 (warning-with-location simple-warning)
84 ;;;--------------------------------------------------------------------------
85 ;;; Error reporting functions.
87 (defun make-condition-with-location (default-type floc datum &rest arguments)
88 "Construct a CONDITION-WITH-LOCATION given a condition designator.
90 The returned condition will always be a CONDITION-WITH-LOCATION. The
91 process consists of two stages. In the first stage, a condition is
92 constructed from the condition designator DATUM and ARGUMENTS with default
93 type DEFAULT-TYPE (a symbol). The precise behaviour depends on DATUM:
95 * If DATUM is a condition, then it is used as-is; ARGUMENTS should be an
98 * If DATUM is a symbol, then it must name a condition type. An instance
99 of this class is constructed using ARGUMENTS as initargs, i.e., as
100 if (apply #'make-condition ARGUMENTS); if the type is a subtype of
101 CONDITION-WITH-LOCATION then FLOC is attached as the location.
103 * If DATUM is a format control (i.e., a string or function), then the
104 condition is constructed as if, instead, DEFAULT-TYPE had been
105 supplied as DATUM, and the list (:format-control DATUM
106 :format-arguments ARGUMENTS) supplied as ARGUMENTS.
108 In the second stage, the condition constructed by the first stage is
109 converted into a CONDITION-WITH-LOCATION. If the condition already has
110 type CONDITION-WITH-LOCATION then it is returned as is. Otherwise it is
111 wrapped in an appropriate subtype of ENCLOSING-CONDITION-WITH-LOCATION:
112 if the condition was a subtype of ERROR or WARNING then the resulting
113 condition will also be subtype of ERROR or WARNING as appropriate."
115 (labels ((wrap (condition)
118 (error 'enclosing-error-with-location)
119 (warning 'enclosing-warning-with-location)
120 (condition 'enclosing-condition-with-location))
122 :location (file-location floc)))
123 (make (type &rest initargs)
124 (if (subtypep type 'condition-with-location)
125 (apply #'make-condition type
126 :location (file-location floc)
128 (wrap (apply #'make-condition type initargs)))))
130 (condition-with-location datum)
131 (condition (wrap datum))
132 (symbol (apply #'make arguments))
133 ((or string function) (make default-type
134 :format-control datum
135 :format-arguments arguments)))))
137 (defun error-with-location (floc datum &rest arguments)
138 "Report an error with attached location information."
139 (error (apply #'make-condition-with-location
140 'simple-error-with-location
141 floc datum arguments)))
143 (defun warn-with-location (floc datum &rest arguments)
144 "Report a warning with attached location information."
145 (warn (apply #'make-condition-with-location
146 'simple-warning-with-location
147 floc datum arguments)))
149 (defun cerror-with-location (floc continue-string datum &rest arguments)
150 "Report a continuable error with attached location information."
151 (cerror continue-string
152 (apply #'make-condition-with-location
153 'simple-error-with-location
154 floc datum arguments)))
156 (defun cerror* (datum &rest arguments)
157 (apply #'cerror "Continue" datum arguments))
159 (defun cerror*-with-location (floc datum &rest arguments)
160 (apply #'cerror-with-location floc "Continue" datum arguments))
162 (defun count-and-report-errors* (thunk)
163 "Invoke THUNK in a dynamic environment which traps and reports errors.
165 See the COUNT-AND-REPORT-ERRORS macro for more detais."
170 ((error (lambda (error)
171 (let ((fatal (not (find-restart 'continue error))))
172 (format *error-output* "~&~A: ~:[~;Fatal error: ~]~A~%"
173 (file-location error)
178 (return-from count-and-report-errors*
179 (values nil errors warnings))
180 (invoke-restart 'continue)))))
181 (warning (lambda (warning)
182 (format *error-output* "~&~A: Warning: ~A~%"
183 (file-location warning)
186 (invoke-restart 'muffle-warning))))
187 (values (funcall thunk)
191 (defmacro count-and-report-errors (() &body body)
192 "Evaluate BODY in a dynamic environment which traps and reports errors.
194 The BODY is evaluated. If an error or warning is signalled, it is
195 reported (using its report function), and counted. Warnings are otherwise
196 muffled; continuable errors (i.e., when a CONTINUE restart is defined) are
197 continued; non-continuable errors cause an immediate exit from the BODY.
199 The final value consists of three values: the primary value of the BODY
200 (or NIL if a non-continuable error occurred), the number of errors
201 reported, and the number of warnings reported."
202 `(count-and-report-errors* (lambda () ,@body)))
204 (defun with-default-error-location* (floc thunk)
205 "Invoke THUNK in a dynamic environment which attaches FLOC to errors (and
206 other conditions) which do not have file location information attached to
209 See the WITH-DEFAULT-ERROR-LOCATION macro for more details."
213 ((condition-with-location (lambda (condition)
214 (declare (ignore condition))
216 (condition (lambda (condition)
217 (signal (make-condition-with-location nil
223 (defmacro with-default-error-location ((floc) &body body)
224 "Evaluate BODY in a dynamic environment which attaches FLOC to errors (and
225 other conditions) which do not have file location information attached to
228 If a condition other than a CONDITION-WITH-LOCATION is signalled during
229 the evaluation of the BODY, then an instance of an appropriate subtype of
230 ENCLOSING-CONDITION-WITH-LOCATION is constructed, enclosing the original
231 condition, and signalled. If the original condition was a subtype of
232 ERROR or WARNING, then the new condition will also be a subtype of ERROR
233 or WARNING as appropriate.
235 The FLOC argument is coerced to a FILE-LOCATION object each time a
236 condition is signalled. For example, if FLOC is a lexical analyser object
237 which reports its current position in response to FILE-LOCATION, then each
238 condition will be reported as arising at the lexer's current position at
239 that time, rather than all being reported at the same position.
241 If the new enclosing condition is not handled, the handler established by
242 this macro will decline to handle the original condition. Typically,
243 however, the new condition will be handled by COUNT-AND-REPORT-ERRORS."
244 `(with-default-error-location* ,floc (lambda () ,@body)))
246 ;;;----- That's all, folks --------------------------------------------------