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 | ||
e43bd955 | 137 | (export 'info) |
db6c3279 MW |
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 | ||
e43bd955 MW |
148 | (export 'noted) |
149 | (defun noted (&optional condition) | |
150 | "Invoke the `noted' restart, possibly associated with the given CONDITION." | |
151 | (invoke-associated-restart 'noted condition)) | |
152 | ||
db6c3279 MW |
153 | (export 'simple-information-with-location) |
154 | (define-condition simple-information-with-location | |
155 | (information-with-location simple-information) | |
156 | ()) | |
157 | ||
abdf50aa | 158 | ;;;-------------------------------------------------------------------------- |
dea4d055 | 159 | ;;; Reporting errors. |
abdf50aa | 160 | |
388ab382 MW |
161 | (export 'enclosing-condition-with-location-type) |
162 | (defgeneric enclosing-condition-with-location-type (condition) | |
163 | (:documentation | |
164 | "Return a class suitable for attaching location information to CONDITION. | |
165 | ||
166 | Specifically, return the name of a subclass of `enclosing-condition- | |
167 | with-location' suitable to enclose CONDITION.") | |
168 | (:method ((condition error)) 'enclosing-error-with-location) | |
169 | (:method ((condition warning)) 'enclosing-warning-with-location) | |
db6c3279 | 170 | (:method ((condition information)) 'enclosing-information-with-location) |
388ab382 MW |
171 | (:method ((condition condition)) 'enclosing-condition-with-location)) |
172 | ||
dea4d055 | 173 | (export 'make-condition-with-location) |
abdf50aa | 174 | (defun make-condition-with-location (default-type floc datum &rest arguments) |
3109662a | 175 | "Construct a `condition-with-location' given a condition designator. |
abdf50aa | 176 | |
3109662a | 177 | The returned condition will always be a `condition-with-location'. The |
abdf50aa MW |
178 | process consists of two stages. In the first stage, a condition is |
179 | constructed from the condition designator DATUM and ARGUMENTS with default | |
180 | type DEFAULT-TYPE (a symbol). The precise behaviour depends on DATUM: | |
181 | ||
182 | * If DATUM is a condition, then it is used as-is; ARGUMENTS should be an | |
183 | empty list. | |
184 | ||
185 | * If DATUM is a symbol, then it must name a condition type. An instance | |
186 | of this class is constructed using ARGUMENTS as initargs, i.e., as | |
187 | if (apply #'make-condition ARGUMENTS); if the type is a subtype of | |
3109662a | 188 | `condition-with-location' then FLOC is attached as the location. |
abdf50aa MW |
189 | |
190 | * If DATUM is a format control (i.e., a string or function), then the | |
191 | condition is constructed as if, instead, DEFAULT-TYPE had been | |
192 | supplied as DATUM, and the list (:format-control DATUM | |
193 | :format-arguments ARGUMENTS) supplied as ARGUMENTS. | |
194 | ||
195 | In the second stage, the condition constructed by the first stage is | |
3109662a MW |
196 | converted into a `condition-with-location'. If the condition already has |
197 | type `condition-with-location' then it is returned as is. Otherwise it is | |
198 | wrapped in an appropriate subtype of `enclosing-condition-with-location': | |
abdf50aa MW |
199 | if the condition was a subtype of ERROR or WARNING then the resulting |
200 | condition will also be subtype of ERROR or WARNING as appropriate." | |
201 | ||
ad131652 MW |
202 | (labels ((check-no-args () |
203 | (unless (null arguments) | |
204 | (error "Argument list provided with specific condition"))) | |
205 | (wrap (condition) | |
abdf50aa | 206 | (make-condition |
388ab382 | 207 | (enclosing-condition-with-location-type condition) |
abdf50aa MW |
208 | :condition condition |
209 | :location (file-location floc))) | |
210 | (make (type &rest initargs) | |
211 | (if (subtypep type 'condition-with-location) | |
212 | (apply #'make-condition type | |
213 | :location (file-location floc) | |
214 | initargs) | |
215 | (wrap (apply #'make-condition type initargs))))) | |
ad131652 MW |
216 | (typecase datum |
217 | (condition-with-location (check-no-args) datum) | |
218 | (condition (check-no-args) (wrap datum)) | |
89ef4001 | 219 | (symbol (apply #'make datum arguments)) |
abdf50aa MW |
220 | ((or string function) (make default-type |
221 | :format-control datum | |
ad131652 MW |
222 | :format-arguments arguments)) |
223 | (t (error "Unexpected condition designator datum ~S" datum))))) | |
abdf50aa | 224 | |
dea4d055 | 225 | (export 'error-with-location) |
abdf50aa MW |
226 | (defun error-with-location (floc datum &rest arguments) |
227 | "Report an error with attached location information." | |
228 | (error (apply #'make-condition-with-location | |
229 | 'simple-error-with-location | |
230 | floc datum arguments))) | |
231 | ||
dea4d055 | 232 | (export 'warn-with-location) |
abdf50aa MW |
233 | (defun warn-with-location (floc datum &rest arguments) |
234 | "Report a warning with attached location information." | |
235 | (warn (apply #'make-condition-with-location | |
236 | 'simple-warning-with-location | |
237 | floc datum arguments))) | |
238 | ||
db6c3279 MW |
239 | (export 'info-with-location) |
240 | (defun info-with-location (floc datum &rest arguments) | |
241 | "Report some information with attached location information." | |
242 | (info (apply #'make-condition-with-location | |
243 | 'simple-information-with-location | |
244 | floc datum arguments))) | |
245 | ||
9ec578d9 MW |
246 | (defun my-cerror (continue-string datum &rest arguments) |
247 | "Like standard `cerror', but robust against sneaky changes of conditions. | |
248 | ||
249 | It seems that `cerror' (well, at least the version in SBCL) is careful | |
250 | to limit its restart to the specific condition it signalled. But that's | |
251 | annoying, because `with-default-error-location' substitutes different | |
252 | conditions carrying the error-location information." | |
253 | (restart-case (apply #'error datum arguments) | |
254 | (continue () | |
255 | :report (lambda (stream) | |
256 | (apply #'format stream continue-string datum arguments)) | |
257 | nil))) | |
258 | ||
dea4d055 | 259 | (export 'cerror-with-location) |
abdf50aa MW |
260 | (defun cerror-with-location (floc continue-string datum &rest arguments) |
261 | "Report a continuable error with attached location information." | |
9ec578d9 MW |
262 | (my-cerror continue-string |
263 | (apply #'make-condition-with-location | |
264 | 'simple-error-with-location | |
265 | floc datum arguments))) | |
abdf50aa | 266 | |
dea4d055 | 267 | (export 'cerror*) |
abdf50aa | 268 | (defun cerror* (datum &rest arguments) |
9ec578d9 | 269 | (apply #'my-cerror "Continue" datum arguments)) |
abdf50aa | 270 | |
dea4d055 | 271 | (export 'cerror*-with-location) |
abdf50aa MW |
272 | (defun cerror*-with-location (floc datum &rest arguments) |
273 | (apply #'cerror-with-location floc "Continue" datum arguments)) | |
274 | ||
dea4d055 MW |
275 | ;;;-------------------------------------------------------------------------- |
276 | ;;; Stamping errors with location information. | |
277 | ||
278 | (defun with-default-error-location* (floc thunk) | |
279 | "Invoke THUNK in a dynamic environment which attaches FLOC to errors (and | |
280 | other conditions) which do not have file location information attached to | |
281 | them already. | |
282 | ||
3109662a | 283 | See the `with-default-error-location' macro for more details." |
dea4d055 MW |
284 | |
285 | (if floc | |
286 | (handler-bind | |
287 | ((condition-with-location | |
288 | (lambda (condition) | |
289 | (declare (ignore condition)) | |
290 | :decline)) | |
291 | (condition | |
292 | (lambda (condition) | |
293 | (signal (make-condition-with-location nil floc condition))))) | |
294 | (funcall thunk)) | |
295 | (funcall thunk))) | |
296 | ||
297 | (export 'with-default-error-location) | |
298 | (defmacro with-default-error-location ((floc) &body body) | |
299 | "Evaluate BODY, as an implicit progn, in a dynamic environment which | |
300 | attaches FLOC to errors (and other conditions) which do not have file | |
301 | location information attached to them already. | |
302 | ||
3109662a | 303 | If a condition other than a `condition-with-location' is signalled during |
dea4d055 | 304 | the evaluation of the BODY, then an instance of an appropriate subcalass |
3109662a | 305 | of `enclosing-condition-with-location' is constructed, enclosing the |
dea4d055 MW |
306 | original condition, and signalled. In particular, if the original |
307 | condition was a subtype of ERROR or WARNING, then the new condition will | |
308 | also be a subtype of ERROR or WARNING as appropriate. | |
309 | ||
3109662a | 310 | The FLOC argument is coerced to a `file-location' object each time a |
dea4d055 | 311 | condition is signalled. For example, if FLOC is a lexical analyser object |
3109662a MW |
312 | which reports its current position in response to `file-location', then |
313 | each condition will be reported as arising at the lexer's current position | |
314 | at that time, rather than all being reported at the same position. | |
dea4d055 MW |
315 | |
316 | If the new enclosing condition is not handled, the handler established by | |
317 | this macro will decline to handle the original condition. Typically, | |
3109662a | 318 | however, the new condition will be handled by `count-and-report-errors'. |
dea4d055 MW |
319 | |
320 | As a special case, if FLOC is nil, then no special action is taken, and | |
321 | BODY is simply evaluated, as an implicit progn." | |
322 | ||
323 | `(with-default-error-location* ,floc (lambda () ,@body))) | |
324 | ||
40d95de7 MW |
325 | ;;;-------------------------------------------------------------------------- |
326 | ;;; Custom errors for parsers. | |
327 | ||
328 | ;; Resolve dependency cycle. | |
329 | (export '(parser-error-expected parser-error-found)) | |
330 | (defgeneric parser-error-expected (condition)) | |
331 | (defgeneric parser-error-found (condition)) | |
332 | ||
333 | (export 'report-parser-error) | |
334 | (defun report-parser-error (error stream show-expected show-found) | |
335 | (format stream "~:[Unexpected~;~ | |
336 | Expected ~:*~{~#[~;~A~;~A or ~A~:;~ | |
337 | ~@{~A, ~#[~;or ~A~]~}~]~} but found~] ~ | |
338 | ~A" | |
339 | (mapcar show-expected (parser-error-expected error)) | |
340 | (funcall show-found (parser-error-found error)))) | |
341 | ||
342 | (export 'parser-error) | |
343 | (define-condition parser-error (error) | |
344 | ((expected :initarg :expected :reader parser-error-expected :type list) | |
345 | (found :initarg :found :reader parser-error-found :type t)) | |
346 | (:documentation "Standard error from a parser. | |
347 | ||
348 | Supports the usual kinds of parser failure, where the parser was expecting | |
349 | some kinds of things but found something else.") | |
350 | (:report (lambda (error stream) | |
351 | (report-parser-error error stream | |
352 | #'prin1-to-string #'prin1-to-string)))) | |
353 | ||
354 | (export '(base-lexer-error simple-lexer-error)) | |
355 | (define-condition base-lexer-error (error-with-location) ()) | |
356 | (define-condition simple-lexer-error | |
357 | (base-lexer-error simple-error-with-location) | |
358 | ()) | |
359 | ||
360 | (export '(base-syntax-error simple-syntax-error)) | |
361 | (define-condition base-syntax-error (error-with-location) ()) | |
362 | (define-condition simple-syntax-error | |
363 | (base-syntax-error simple-error-with-location) | |
364 | ()) | |
365 | ||
dea4d055 MW |
366 | ;;;-------------------------------------------------------------------------- |
367 | ;;; Front-end error reporting. | |
368 | ||
40d95de7 MW |
369 | (export 'classify-condition) |
370 | (defgeneric classify-condition (condition) | |
371 | (:method ((condition error)) "error") | |
372 | (:method ((condition base-lexer-error)) "lexical error") | |
373 | (:method ((condition base-syntax-error)) "syntax error") | |
374 | (:method ((condition warning)) "warning") | |
375 | (:method ((condition information)) "note")) | |
376 | ||
abdf50aa MW |
377 | (defun count-and-report-errors* (thunk) |
378 | "Invoke THUNK in a dynamic environment which traps and reports errors. | |
379 | ||
9ec578d9 | 380 | See the `count-and-report-errors' macro for more details." |
abdf50aa MW |
381 | |
382 | (let ((errors 0) | |
383 | (warnings 0)) | |
9ec578d9 MW |
384 | (restart-case |
385 | (let ((our-continue-restart (find-restart 'continue))) | |
40d95de7 MW |
386 | (flet ((report (condition &optional indicator) |
387 | (let ((*print-pretty* nil)) | |
388 | (format *error-output* | |
389 | "~&~A: ~@[~A ~]~A: ~A~%" | |
390 | (file-location condition) | |
391 | indicator (classify-condition condition) | |
392 | condition)))) | |
393 | (handler-bind | |
394 | ((error (lambda (error) | |
395 | (let ((fatal (eq (find-restart 'continue error) | |
396 | our-continue-restart))) | |
397 | (report error (and fatal "fatal")) | |
398 | (incf errors) | |
399 | (if fatal | |
400 | (return-from count-and-report-errors* | |
401 | (values nil errors warnings)) | |
402 | (continue error))))) | |
403 | (warning (lambda (warning) | |
404 | (report warning) | |
405 | (incf warnings) | |
406 | (muffle-warning warning))) | |
407 | (information (lambda (info) | |
408 | (report info) | |
409 | (noted info)))) | |
410 | (values (funcall thunk) | |
411 | errors | |
412 | warnings)))) | |
9ec578d9 MW |
413 | (continue () |
414 | :report (lambda (stream) (write-string "Exit to top-level" stream)) | |
415 | (values nil errors warnings))))) | |
abdf50aa | 416 | |
dea4d055 | 417 | (export 'count-and-report-errors) |
abdf50aa MW |
418 | (defmacro count-and-report-errors (() &body body) |
419 | "Evaluate BODY in a dynamic environment which traps and reports errors. | |
420 | ||
421 | The BODY is evaluated. If an error or warning is signalled, it is | |
422 | reported (using its report function), and counted. Warnings are otherwise | |
3109662a MW |
423 | muffled; continuable errors (i.e., when a `continue' restart is defined) |
424 | are continued; non-continuable errors cause an immediate exit from the | |
425 | BODY. | |
abdf50aa MW |
426 | |
427 | The final value consists of three values: the primary value of the BODY | |
3109662a | 428 | (or nil if a non-continuable error occurred), the number of errors |
abdf50aa MW |
429 | reported, and the number of warnings reported." |
430 | `(count-and-report-errors* (lambda () ,@body))) | |
431 | ||
abdf50aa | 432 | ;;;----- That's all, folks -------------------------------------------------- |