Commit | Line | Data |
---|---|---|
abdf50aa MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Error types and handling utilities | |
4 | ;;; | |
5 | ;;; (c) 2009 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
10 | ;;; This file is part of the Simple Object Definition system. | |
11 | ;;; | |
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. | |
16 | ;;; | |
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. | |
21 | ;;; | |
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. | |
25 | ||
26 | (cl:in-package #:sod) | |
27 | ||
28 | ;;;-------------------------------------------------------------------------- | |
29 | ;;; Enclosing conditions. | |
30 | ||
31 | (define-condition enclosing-condition (condition) | |
dea4d055 | 32 | ((enclosed-condition :initarg :condition :type condition |
abdf50aa MW |
33 | :reader enclosed-condition)) |
34 | (:documentation | |
35 | "A condition which encloses another condition | |
36 | ||
37 | This is useful if one wants to attach additional information to an | |
38 | existing condition. The enclosed condition can be obtained using the | |
39 | ENCLOSED-CONDITION function.") | |
40 | (:report (lambda (condition stream) | |
41 | (princ (enclosed-condition condition) stream)))) | |
42 | ||
43 | ;;;-------------------------------------------------------------------------- | |
44 | ;;; Conditions with location information. | |
45 | ||
46 | (define-condition condition-with-location (condition) | |
dea4d055 | 47 | ((location :initarg :location :reader file-location :type file-location)) |
abdf50aa MW |
48 | (:documentation |
49 | "A condition which has some location information attached.")) | |
50 | ||
51 | (define-condition enclosing-condition-with-location | |
52 | (condition-with-location enclosing-condition) | |
53 | ()) | |
54 | ||
55 | (define-condition error-with-location (condition-with-location error) | |
56 | ()) | |
57 | ||
58 | (define-condition warning-with-location (condition-with-location warning) | |
59 | ()) | |
60 | ||
61 | (define-condition enclosing-error-with-location | |
62 | (enclosing-condition-with-location error) | |
63 | ()) | |
64 | ||
65 | (define-condition enclosing-warning-with-location | |
66 | (enclosing-condition-with-location warning) | |
67 | ()) | |
68 | ||
69 | (define-condition simple-condition-with-location | |
70 | (condition-with-location simple-condition) | |
71 | ()) | |
72 | ||
73 | (define-condition simple-error-with-location | |
74 | (error-with-location simple-error) | |
75 | ()) | |
76 | ||
77 | (define-condition simple-warning-with-location | |
78 | (warning-with-location simple-warning) | |
79 | ()) | |
80 | ||
81 | ;;;-------------------------------------------------------------------------- | |
82 | ;;; Error reporting functions. | |
83 | ||
84 | (defun make-condition-with-location (default-type floc datum &rest arguments) | |
85 | "Construct a CONDITION-WITH-LOCATION given a condition designator. | |
86 | ||
87 | The returned condition will always be a CONDITION-WITH-LOCATION. The | |
88 | process consists of two stages. In the first stage, a condition is | |
89 | constructed from the condition designator DATUM and ARGUMENTS with default | |
90 | type DEFAULT-TYPE (a symbol). The precise behaviour depends on DATUM: | |
91 | ||
92 | * If DATUM is a condition, then it is used as-is; ARGUMENTS should be an | |
93 | empty list. | |
94 | ||
95 | * If DATUM is a symbol, then it must name a condition type. An instance | |
96 | of this class is constructed using ARGUMENTS as initargs, i.e., as | |
97 | if (apply #'make-condition ARGUMENTS); if the type is a subtype of | |
98 | CONDITION-WITH-LOCATION then FLOC is attached as the location. | |
99 | ||
100 | * If DATUM is a format control (i.e., a string or function), then the | |
101 | condition is constructed as if, instead, DEFAULT-TYPE had been | |
102 | supplied as DATUM, and the list (:format-control DATUM | |
103 | :format-arguments ARGUMENTS) supplied as ARGUMENTS. | |
104 | ||
105 | In the second stage, the condition constructed by the first stage is | |
106 | converted into a CONDITION-WITH-LOCATION. If the condition already has | |
107 | type CONDITION-WITH-LOCATION then it is returned as is. Otherwise it is | |
108 | wrapped in an appropriate subtype of ENCLOSING-CONDITION-WITH-LOCATION: | |
109 | if the condition was a subtype of ERROR or WARNING then the resulting | |
110 | condition will also be subtype of ERROR or WARNING as appropriate." | |
111 | ||
112 | (labels ((wrap (condition) | |
113 | (make-condition | |
114 | (etypecase condition | |
115 | (error 'enclosing-error-with-location) | |
116 | (warning 'enclosing-warning-with-location) | |
117 | (condition 'enclosing-condition-with-location)) | |
118 | :condition condition | |
119 | :location (file-location floc))) | |
120 | (make (type &rest initargs) | |
121 | (if (subtypep type 'condition-with-location) | |
122 | (apply #'make-condition type | |
123 | :location (file-location floc) | |
124 | initargs) | |
125 | (wrap (apply #'make-condition type initargs))))) | |
126 | (etypecase datum | |
127 | (condition-with-location datum) | |
128 | (condition (wrap datum)) | |
129 | (symbol (apply #'make arguments)) | |
130 | ((or string function) (make default-type | |
131 | :format-control datum | |
132 | :format-arguments arguments))))) | |
133 | ||
134 | (defun error-with-location (floc datum &rest arguments) | |
135 | "Report an error with attached location information." | |
136 | (error (apply #'make-condition-with-location | |
137 | 'simple-error-with-location | |
138 | floc datum arguments))) | |
139 | ||
140 | (defun warn-with-location (floc datum &rest arguments) | |
141 | "Report a warning with attached location information." | |
142 | (warn (apply #'make-condition-with-location | |
143 | 'simple-warning-with-location | |
144 | floc datum arguments))) | |
145 | ||
146 | (defun cerror-with-location (floc continue-string datum &rest arguments) | |
147 | "Report a continuable error with attached location information." | |
148 | (cerror continue-string | |
149 | (apply #'make-condition-with-location | |
150 | 'simple-error-with-location | |
151 | floc datum arguments))) | |
152 | ||
153 | (defun cerror* (datum &rest arguments) | |
154 | (apply #'cerror "Continue" datum arguments)) | |
155 | ||
156 | (defun cerror*-with-location (floc datum &rest arguments) | |
157 | (apply #'cerror-with-location floc "Continue" datum arguments)) | |
158 | ||
159 | (defun count-and-report-errors* (thunk) | |
160 | "Invoke THUNK in a dynamic environment which traps and reports errors. | |
161 | ||
162 | See the COUNT-AND-REPORT-ERRORS macro for more detais." | |
163 | ||
164 | (let ((errors 0) | |
165 | (warnings 0)) | |
166 | (handler-bind | |
167 | ((error (lambda (error) | |
168 | (let ((fatal (not (find-restart 'continue error)))) | |
169 | (format *error-output* "~&~A: ~:[~;Fatal error: ~]~A~%" | |
170 | (file-location error) | |
171 | fatal | |
172 | error) | |
173 | (incf errors) | |
174 | (if fatal | |
175 | (return-from count-and-report-errors* | |
176 | (values nil errors warnings)) | |
177 | (invoke-restart 'continue))))) | |
178 | (warning (lambda (warning) | |
179 | (format *error-output* "~&~A: Warning: ~A~%" | |
180 | (file-location warning) | |
181 | warning) | |
182 | (incf warnings) | |
183 | (invoke-restart 'muffle-warning)))) | |
184 | (values (funcall thunk) | |
185 | errors | |
186 | warnings)))) | |
187 | ||
188 | (defmacro count-and-report-errors (() &body body) | |
189 | "Evaluate BODY in a dynamic environment which traps and reports errors. | |
190 | ||
191 | The BODY is evaluated. If an error or warning is signalled, it is | |
192 | reported (using its report function), and counted. Warnings are otherwise | |
193 | muffled; continuable errors (i.e., when a CONTINUE restart is defined) are | |
194 | continued; non-continuable errors cause an immediate exit from the BODY. | |
195 | ||
196 | The final value consists of three values: the primary value of the BODY | |
197 | (or NIL if a non-continuable error occurred), the number of errors | |
198 | reported, and the number of warnings reported." | |
199 | `(count-and-report-errors* (lambda () ,@body))) | |
200 | ||
201 | (defun with-default-error-location* (floc thunk) | |
202 | "Invoke THUNK in a dynamic environment which attaches FLOC to errors (and | |
203 | other conditions) which do not have file location information attached to | |
204 | them already. | |
205 | ||
206 | See the WITH-DEFAULT-ERROR-LOCATION macro for more details." | |
207 | ||
208 | (if floc | |
209 | (handler-bind | |
210 | ((condition-with-location (lambda (condition) | |
211 | (declare (ignore condition)) | |
212 | :decline)) | |
213 | (condition (lambda (condition) | |
214 | (signal (make-condition-with-location nil | |
215 | floc | |
216 | condition))))) | |
217 | (funcall thunk)) | |
218 | (funcall thunk))) | |
219 | ||
220 | (defmacro with-default-error-location ((floc) &body body) | |
221 | "Evaluate BODY in a dynamic environment which attaches FLOC to errors (and | |
222 | other conditions) which do not have file location information attached to | |
223 | them already. | |
224 | ||
225 | If a condition other than a CONDITION-WITH-LOCATION is signalled during | |
226 | the evaluation of the BODY, then an instance of an appropriate subtype of | |
227 | ENCLOSING-CONDITION-WITH-LOCATION is constructed, enclosing the original | |
228 | condition, and signalled. If the original condition was a subtype of | |
229 | ERROR or WARNING, then the new condition will also be a subtype of ERROR | |
230 | or WARNING as appropriate. | |
231 | ||
232 | The FLOC argument is coerced to a FILE-LOCATION object each time a | |
233 | condition is signalled. For example, if FLOC is a lexical analyser object | |
234 | which reports its current position in response to FILE-LOCATION, then each | |
235 | condition will be reported as arising at the lexer's current position at | |
236 | that time, rather than all being reported at the same position. | |
237 | ||
238 | If the new enclosing condition is not handled, the handler established by | |
239 | this macro will decline to handle the original condition. Typically, | |
240 | however, the new condition will be handled by COUNT-AND-REPORT-ERRORS." | |
241 | `(with-default-error-location* ,floc (lambda () ,@body))) | |
242 | ||
243 | ;;;----- That's all, folks -------------------------------------------------- |