Commit | Line | Data |
---|---|---|
abdf50aa MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
dea4d055 | 3 | ;;; Protocol for file locations |
abdf50aa MW |
4 | ;;; |
5 | ;;; (c) 2009 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
e0808c47 | 10 | ;;; This file is part of the Sensible Object Design, an object system for C. |
abdf50aa MW |
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 | ||
dea4d055 MW |
26 | (cl:in-package #:sod-parser) |
27 | ||
28 | ;;;-------------------------------------------------------------------------- | |
29 | ;;; File location objects. | |
30 | ||
31 | (export '(file-location make-file-location file-location-p | |
32 | file-location-filename file-location-line file-location-column)) | |
33 | (defstruct (file-location | |
34 | (:constructor make-file-location | |
9ec578d9 | 35 | (%filename &optional line column |
dea4d055 MW |
36 | &aux (filename |
37 | (etypecase %filename | |
38 | ((or string null) %filename) | |
39 | (pathname (namestring %filename))))))) | |
40 | "A simple structure containing file location information. | |
41 | ||
3109662a MW |
42 | Construct using `make-file-location'; the main useful function is |
43 | `error-file-location'." | |
dea4d055 MW |
44 | (filename nil :type (or string null) :read-only t) |
45 | (line nil :type (or fixnum null) :read-only t) | |
46 | (column nil :type (or fixnum null) :read-only t)) | |
47 | ||
48 | (defgeneric file-location (thing) | |
49 | (:documentation | |
3109662a | 50 | "Convert THING into a `file-location', if possible. |
dea4d055 | 51 | |
3109662a | 52 | A THING which can be converted into a `file-location' is termed a |
dea4d055 MW |
53 | `file-location designator'.") |
54 | (:method ((thing file-location)) thing)) | |
abdf50aa MW |
55 | |
56 | ;;;-------------------------------------------------------------------------- | |
57 | ;;; Enclosing conditions. | |
58 | ||
dea4d055 | 59 | (export '(enclosing-condition enclosed-condition)) |
abdf50aa | 60 | (define-condition enclosing-condition (condition) |
4b8e5c03 MW |
61 | ((%enclosed-condition :initarg :condition :type condition |
62 | :reader enclosed-condition)) | |
abdf50aa MW |
63 | (:documentation |
64 | "A condition which encloses another condition | |
65 | ||
66 | This is useful if one wants to attach additional information to an | |
67 | existing condition. The enclosed condition can be obtained using the | |
3109662a | 68 | `enclosed-condition' function.") |
abdf50aa MW |
69 | (:report (lambda (condition stream) |
70 | (princ (enclosed-condition condition) stream)))) | |
71 | ||
72 | ;;;-------------------------------------------------------------------------- | |
73 | ;;; Conditions with location information. | |
74 | ||
dea4d055 | 75 | (export 'condition-with-location) |
abdf50aa | 76 | (define-condition condition-with-location (condition) |
dea4d055 | 77 | ((location :initarg :location :reader file-location :type file-location)) |
abdf50aa MW |
78 | (:documentation |
79 | "A condition which has some location information attached.")) | |
80 | ||
dea4d055 | 81 | (export 'enclosing-condition-with-location) |
abdf50aa MW |
82 | (define-condition enclosing-condition-with-location |
83 | (condition-with-location enclosing-condition) | |
84 | ()) | |
85 | ||
db6c3279 MW |
86 | (export 'information) |
87 | (define-condition information (condition) | |
88 | ()) | |
89 | ||
dea4d055 | 90 | (export 'error-with-location) |
abdf50aa MW |
91 | (define-condition error-with-location (condition-with-location error) |
92 | ()) | |
93 | ||
dea4d055 | 94 | (export 'warning-with-location) |
abdf50aa MW |
95 | (define-condition warning-with-location (condition-with-location warning) |
96 | ()) | |
97 | ||
db6c3279 MW |
98 | (export 'information-with-location) |
99 | (define-condition information-with-location | |
100 | (condition-with-location information) | |
101 | ()) | |
102 | ||
dea4d055 | 103 | (export 'enclosing-error-with-location) |
abdf50aa MW |
104 | (define-condition enclosing-error-with-location |
105 | (enclosing-condition-with-location error) | |
106 | ()) | |
107 | ||
dea4d055 | 108 | (export 'enclosing-warning-with-location) |
abdf50aa MW |
109 | (define-condition enclosing-warning-with-location |
110 | (enclosing-condition-with-location warning) | |
111 | ()) | |
112 | ||
db6c3279 MW |
113 | (export 'enclosing-information-with-location) |
114 | (define-condition enclosing-information-with-location | |
115 | (enclosing-condition-with-location information) | |
116 | ()) | |
117 | ||
dea4d055 | 118 | (export 'simple-condition-with-location) |
abdf50aa MW |
119 | (define-condition simple-condition-with-location |
120 | (condition-with-location simple-condition) | |
121 | ()) | |
122 | ||
dea4d055 | 123 | (export 'simple-error-with-location) |
abdf50aa MW |
124 | (define-condition simple-error-with-location |
125 | (error-with-location simple-error) | |
126 | ()) | |
127 | ||
dea4d055 | 128 | (export 'simple-warning-with-location) |
abdf50aa MW |
129 | (define-condition simple-warning-with-location |
130 | (warning-with-location simple-warning) | |
131 | ()) | |
132 | ||
db6c3279 MW |
133 | (export 'simple-information) |
134 | (define-condition simple-information (simple-condition information) | |
135 | ()) | |
136 | ||
137 | (export '(info noted)) | |
138 | (defun info (datum &rest arguments) | |
139 | "Report some useful diagnostic information. | |
140 | ||
141 | Establish a simple restart named `noted', and signal the condition of type | |
142 | `information' designated by DATUM and ARGUMENTS. Return non-nil if the | |
143 | restart was invoked, otherwise nil." | |
144 | (restart-case | |
145 | (signal (designated-condition 'simple-information datum arguments)) | |
146 | (noted () :report "Noted." t))) | |
147 | ||
148 | (export 'simple-information-with-location) | |
149 | (define-condition simple-information-with-location | |
150 | (information-with-location simple-information) | |
151 | ()) | |
152 | ||
abdf50aa | 153 | ;;;-------------------------------------------------------------------------- |
dea4d055 | 154 | ;;; Reporting errors. |
abdf50aa | 155 | |
388ab382 MW |
156 | (export 'enclosing-condition-with-location-type) |
157 | (defgeneric enclosing-condition-with-location-type (condition) | |
158 | (:documentation | |
159 | "Return a class suitable for attaching location information to CONDITION. | |
160 | ||
161 | Specifically, return the name of a subclass of `enclosing-condition- | |
162 | with-location' suitable to enclose CONDITION.") | |
163 | (:method ((condition error)) 'enclosing-error-with-location) | |
164 | (:method ((condition warning)) 'enclosing-warning-with-location) | |
db6c3279 | 165 | (:method ((condition information)) 'enclosing-information-with-location) |
388ab382 MW |
166 | (:method ((condition condition)) 'enclosing-condition-with-location)) |
167 | ||
dea4d055 | 168 | (export 'make-condition-with-location) |
abdf50aa | 169 | (defun make-condition-with-location (default-type floc datum &rest arguments) |
3109662a | 170 | "Construct a `condition-with-location' given a condition designator. |
abdf50aa | 171 | |
3109662a | 172 | The returned condition will always be a `condition-with-location'. The |
abdf50aa MW |
173 | process consists of two stages. In the first stage, a condition is |
174 | constructed from the condition designator DATUM and ARGUMENTS with default | |
175 | type DEFAULT-TYPE (a symbol). The precise behaviour depends on DATUM: | |
176 | ||
177 | * If DATUM is a condition, then it is used as-is; ARGUMENTS should be an | |
178 | empty list. | |
179 | ||
180 | * If DATUM is a symbol, then it must name a condition type. An instance | |
181 | of this class is constructed using ARGUMENTS as initargs, i.e., as | |
182 | if (apply #'make-condition ARGUMENTS); if the type is a subtype of | |
3109662a | 183 | `condition-with-location' then FLOC is attached as the location. |
abdf50aa MW |
184 | |
185 | * If DATUM is a format control (i.e., a string or function), then the | |
186 | condition is constructed as if, instead, DEFAULT-TYPE had been | |
187 | supplied as DATUM, and the list (:format-control DATUM | |
188 | :format-arguments ARGUMENTS) supplied as ARGUMENTS. | |
189 | ||
190 | In the second stage, the condition constructed by the first stage is | |
3109662a MW |
191 | converted into a `condition-with-location'. If the condition already has |
192 | type `condition-with-location' then it is returned as is. Otherwise it is | |
193 | wrapped in an appropriate subtype of `enclosing-condition-with-location': | |
abdf50aa MW |
194 | if the condition was a subtype of ERROR or WARNING then the resulting |
195 | condition will also be subtype of ERROR or WARNING as appropriate." | |
196 | ||
ad131652 MW |
197 | (labels ((check-no-args () |
198 | (unless (null arguments) | |
199 | (error "Argument list provided with specific condition"))) | |
200 | (wrap (condition) | |
abdf50aa | 201 | (make-condition |
388ab382 | 202 | (enclosing-condition-with-location-type condition) |
abdf50aa MW |
203 | :condition condition |
204 | :location (file-location floc))) | |
205 | (make (type &rest initargs) | |
206 | (if (subtypep type 'condition-with-location) | |
207 | (apply #'make-condition type | |
208 | :location (file-location floc) | |
209 | initargs) | |
210 | (wrap (apply #'make-condition type initargs))))) | |
ad131652 MW |
211 | (typecase datum |
212 | (condition-with-location (check-no-args) datum) | |
213 | (condition (check-no-args) (wrap datum)) | |
89ef4001 | 214 | (symbol (apply #'make datum arguments)) |
abdf50aa MW |
215 | ((or string function) (make default-type |
216 | :format-control datum | |
ad131652 MW |
217 | :format-arguments arguments)) |
218 | (t (error "Unexpected condition designator datum ~S" datum))))) | |
abdf50aa | 219 | |
dea4d055 | 220 | (export 'error-with-location) |
abdf50aa MW |
221 | (defun error-with-location (floc datum &rest arguments) |
222 | "Report an error with attached location information." | |
223 | (error (apply #'make-condition-with-location | |
224 | 'simple-error-with-location | |
225 | floc datum arguments))) | |
226 | ||
dea4d055 | 227 | (export 'warn-with-location) |
abdf50aa MW |
228 | (defun warn-with-location (floc datum &rest arguments) |
229 | "Report a warning with attached location information." | |
230 | (warn (apply #'make-condition-with-location | |
231 | 'simple-warning-with-location | |
232 | floc datum arguments))) | |
233 | ||
db6c3279 MW |
234 | (export 'info-with-location) |
235 | (defun info-with-location (floc datum &rest arguments) | |
236 | "Report some information with attached location information." | |
237 | (info (apply #'make-condition-with-location | |
238 | 'simple-information-with-location | |
239 | floc datum arguments))) | |
240 | ||
9ec578d9 MW |
241 | (defun my-cerror (continue-string datum &rest arguments) |
242 | "Like standard `cerror', but robust against sneaky changes of conditions. | |
243 | ||
244 | It seems that `cerror' (well, at least the version in SBCL) is careful | |
245 | to limit its restart to the specific condition it signalled. But that's | |
246 | annoying, because `with-default-error-location' substitutes different | |
247 | conditions carrying the error-location information." | |
248 | (restart-case (apply #'error datum arguments) | |
249 | (continue () | |
250 | :report (lambda (stream) | |
251 | (apply #'format stream continue-string datum arguments)) | |
252 | nil))) | |
253 | ||
dea4d055 | 254 | (export 'cerror-with-location) |
abdf50aa MW |
255 | (defun cerror-with-location (floc continue-string datum &rest arguments) |
256 | "Report a continuable error with attached location information." | |
9ec578d9 MW |
257 | (my-cerror continue-string |
258 | (apply #'make-condition-with-location | |
259 | 'simple-error-with-location | |
260 | floc datum arguments))) | |
abdf50aa | 261 | |
dea4d055 | 262 | (export 'cerror*) |
abdf50aa | 263 | (defun cerror* (datum &rest arguments) |
9ec578d9 | 264 | (apply #'my-cerror "Continue" datum arguments)) |
abdf50aa | 265 | |
dea4d055 | 266 | (export 'cerror*-with-location) |
abdf50aa MW |
267 | (defun cerror*-with-location (floc datum &rest arguments) |
268 | (apply #'cerror-with-location floc "Continue" datum arguments)) | |
269 | ||
dea4d055 MW |
270 | ;;;-------------------------------------------------------------------------- |
271 | ;;; Stamping errors with location information. | |
272 | ||
273 | (defun with-default-error-location* (floc thunk) | |
274 | "Invoke THUNK in a dynamic environment which attaches FLOC to errors (and | |
275 | other conditions) which do not have file location information attached to | |
276 | them already. | |
277 | ||
3109662a | 278 | See the `with-default-error-location' macro for more details." |
dea4d055 MW |
279 | |
280 | (if floc | |
281 | (handler-bind | |
282 | ((condition-with-location | |
283 | (lambda (condition) | |
284 | (declare (ignore condition)) | |
285 | :decline)) | |
286 | (condition | |
287 | (lambda (condition) | |
288 | (signal (make-condition-with-location nil floc condition))))) | |
289 | (funcall thunk)) | |
290 | (funcall thunk))) | |
291 | ||
292 | (export 'with-default-error-location) | |
293 | (defmacro with-default-error-location ((floc) &body body) | |
294 | "Evaluate BODY, as an implicit progn, in a dynamic environment which | |
295 | attaches FLOC to errors (and other conditions) which do not have file | |
296 | location information attached to them already. | |
297 | ||
3109662a | 298 | If a condition other than a `condition-with-location' is signalled during |
dea4d055 | 299 | the evaluation of the BODY, then an instance of an appropriate subcalass |
3109662a | 300 | of `enclosing-condition-with-location' is constructed, enclosing the |
dea4d055 MW |
301 | original condition, and signalled. In particular, if the original |
302 | condition was a subtype of ERROR or WARNING, then the new condition will | |
303 | also be a subtype of ERROR or WARNING as appropriate. | |
304 | ||
3109662a | 305 | The FLOC argument is coerced to a `file-location' object each time a |
dea4d055 | 306 | condition is signalled. For example, if FLOC is a lexical analyser object |
3109662a MW |
307 | which reports its current position in response to `file-location', then |
308 | each condition will be reported as arising at the lexer's current position | |
309 | at that time, rather than all being reported at the same position. | |
dea4d055 MW |
310 | |
311 | If the new enclosing condition is not handled, the handler established by | |
312 | this macro will decline to handle the original condition. Typically, | |
3109662a | 313 | however, the new condition will be handled by `count-and-report-errors'. |
dea4d055 MW |
314 | |
315 | As a special case, if FLOC is nil, then no special action is taken, and | |
316 | BODY is simply evaluated, as an implicit progn." | |
317 | ||
318 | `(with-default-error-location* ,floc (lambda () ,@body))) | |
319 | ||
320 | ;;;-------------------------------------------------------------------------- | |
321 | ;;; Front-end error reporting. | |
322 | ||
abdf50aa MW |
323 | (defun count-and-report-errors* (thunk) |
324 | "Invoke THUNK in a dynamic environment which traps and reports errors. | |
325 | ||
9ec578d9 | 326 | See the `count-and-report-errors' macro for more details." |
abdf50aa MW |
327 | |
328 | (let ((errors 0) | |
329 | (warnings 0)) | |
9ec578d9 MW |
330 | (restart-case |
331 | (let ((our-continue-restart (find-restart 'continue))) | |
332 | (handler-bind | |
333 | ((error (lambda (error) | |
334 | (let ((fatal (eq (find-restart 'continue error) | |
335 | our-continue-restart))) | |
336 | (format *error-output* | |
337 | "~&~A: ~:[~;Fatal error: ~]~A~%" | |
338 | (file-location error) | |
339 | fatal | |
340 | error) | |
341 | (incf errors) | |
342 | (if fatal | |
343 | (return-from count-and-report-errors* | |
344 | (values nil errors warnings)) | |
345 | (invoke-restart 'continue))))) | |
346 | (warning (lambda (warning) | |
347 | (format *error-output* "~&~A: Warning: ~A~%" | |
348 | (file-location warning) | |
349 | warning) | |
350 | (incf warnings) | |
db6c3279 MW |
351 | (invoke-restart 'muffle-warning))) |
352 | (information (lambda (info) | |
353 | (format *error-output* "~&~A: Info: ~A~%" | |
354 | (file-location info) | |
355 | info) | |
356 | (invoke-restart 'noted)))) | |
9ec578d9 MW |
357 | (values (funcall thunk) |
358 | errors | |
359 | warnings))) | |
360 | (continue () | |
361 | :report (lambda (stream) (write-string "Exit to top-level" stream)) | |
362 | (values nil errors warnings))))) | |
abdf50aa | 363 | |
dea4d055 | 364 | (export 'count-and-report-errors) |
abdf50aa MW |
365 | (defmacro count-and-report-errors (() &body body) |
366 | "Evaluate BODY in a dynamic environment which traps and reports errors. | |
367 | ||
368 | The BODY is evaluated. If an error or warning is signalled, it is | |
369 | reported (using its report function), and counted. Warnings are otherwise | |
3109662a MW |
370 | muffled; continuable errors (i.e., when a `continue' restart is defined) |
371 | are continued; non-continuable errors cause an immediate exit from the | |
372 | BODY. | |
abdf50aa MW |
373 | |
374 | The final value consists of three values: the primary value of the BODY | |
3109662a | 375 | (or nil if a non-continuable error occurred), the number of errors |
abdf50aa MW |
376 | reported, and the number of warnings reported." |
377 | `(count-and-report-errors* (lambda () ,@body))) | |
378 | ||
abdf50aa | 379 | ;;;----- That's all, folks -------------------------------------------------- |