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 | |
7702b7bc MW |
35 | (%filename |
36 | &optional line column | |
37 | &aux (filename (etypecase %filename | |
38 | ((or string null) %filename) | |
39 | (pathname (namestring %filename))))))) | |
dea4d055 MW |
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 | ;;;-------------------------------------------------------------------------- | |
abdf50aa MW |
57 | ;;; Conditions with location information. |
58 | ||
dea4d055 | 59 | (export 'condition-with-location) |
abdf50aa | 60 | (define-condition condition-with-location (condition) |
dea4d055 | 61 | ((location :initarg :location :reader file-location :type file-location)) |
abdf50aa MW |
62 | (:documentation |
63 | "A condition which has some location information attached.")) | |
64 | ||
dea4d055 | 65 | (export 'enclosing-condition-with-location) |
abdf50aa MW |
66 | (define-condition enclosing-condition-with-location |
67 | (condition-with-location enclosing-condition) | |
68 | ()) | |
69 | ||
dea4d055 | 70 | (export 'error-with-location) |
abdf50aa MW |
71 | (define-condition error-with-location (condition-with-location error) |
72 | ()) | |
73 | ||
dea4d055 | 74 | (export 'warning-with-location) |
abdf50aa MW |
75 | (define-condition warning-with-location (condition-with-location warning) |
76 | ()) | |
77 | ||
db6c3279 MW |
78 | (export 'information-with-location) |
79 | (define-condition information-with-location | |
80 | (condition-with-location information) | |
81 | ()) | |
82 | ||
dea4d055 | 83 | (export 'enclosing-error-with-location) |
abdf50aa MW |
84 | (define-condition enclosing-error-with-location |
85 | (enclosing-condition-with-location error) | |
86 | ()) | |
87 | ||
dea4d055 | 88 | (export 'enclosing-warning-with-location) |
abdf50aa MW |
89 | (define-condition enclosing-warning-with-location |
90 | (enclosing-condition-with-location warning) | |
91 | ()) | |
92 | ||
db6c3279 MW |
93 | (export 'enclosing-information-with-location) |
94 | (define-condition enclosing-information-with-location | |
95 | (enclosing-condition-with-location information) | |
96 | ()) | |
97 | ||
dea4d055 | 98 | (export 'simple-condition-with-location) |
abdf50aa MW |
99 | (define-condition simple-condition-with-location |
100 | (condition-with-location simple-condition) | |
101 | ()) | |
102 | ||
dea4d055 | 103 | (export 'simple-error-with-location) |
abdf50aa MW |
104 | (define-condition simple-error-with-location |
105 | (error-with-location simple-error) | |
106 | ()) | |
107 | ||
dea4d055 | 108 | (export 'simple-warning-with-location) |
abdf50aa MW |
109 | (define-condition simple-warning-with-location |
110 | (warning-with-location simple-warning) | |
111 | ()) | |
112 | ||
db6c3279 MW |
113 | (export 'simple-information-with-location) |
114 | (define-condition simple-information-with-location | |
115 | (information-with-location simple-information) | |
116 | ()) | |
117 | ||
abdf50aa | 118 | ;;;-------------------------------------------------------------------------- |
dea4d055 | 119 | ;;; Reporting errors. |
abdf50aa | 120 | |
388ab382 MW |
121 | (export 'enclosing-condition-with-location-type) |
122 | (defgeneric enclosing-condition-with-location-type (condition) | |
123 | (:documentation | |
124 | "Return a class suitable for attaching location information to CONDITION. | |
125 | ||
126 | Specifically, return the name of a subclass of `enclosing-condition- | |
127 | with-location' suitable to enclose CONDITION.") | |
128 | (:method ((condition error)) 'enclosing-error-with-location) | |
129 | (:method ((condition warning)) 'enclosing-warning-with-location) | |
db6c3279 | 130 | (:method ((condition information)) 'enclosing-information-with-location) |
388ab382 MW |
131 | (:method ((condition condition)) 'enclosing-condition-with-location)) |
132 | ||
dea4d055 | 133 | (export 'make-condition-with-location) |
abdf50aa | 134 | (defun make-condition-with-location (default-type floc datum &rest arguments) |
3109662a | 135 | "Construct a `condition-with-location' given a condition designator. |
abdf50aa | 136 | |
3109662a | 137 | The returned condition will always be a `condition-with-location'. The |
abdf50aa MW |
138 | process consists of two stages. In the first stage, a condition is |
139 | constructed from the condition designator DATUM and ARGUMENTS with default | |
140 | type DEFAULT-TYPE (a symbol). The precise behaviour depends on DATUM: | |
141 | ||
142 | * If DATUM is a condition, then it is used as-is; ARGUMENTS should be an | |
143 | empty list. | |
144 | ||
145 | * If DATUM is a symbol, then it must name a condition type. An instance | |
146 | of this class is constructed using ARGUMENTS as initargs, i.e., as | |
147 | if (apply #'make-condition ARGUMENTS); if the type is a subtype of | |
3109662a | 148 | `condition-with-location' then FLOC is attached as the location. |
abdf50aa MW |
149 | |
150 | * If DATUM is a format control (i.e., a string or function), then the | |
151 | condition is constructed as if, instead, DEFAULT-TYPE had been | |
152 | supplied as DATUM, and the list (:format-control DATUM | |
153 | :format-arguments ARGUMENTS) supplied as ARGUMENTS. | |
154 | ||
155 | In the second stage, the condition constructed by the first stage is | |
3109662a MW |
156 | converted into a `condition-with-location'. If the condition already has |
157 | type `condition-with-location' then it is returned as is. Otherwise it is | |
158 | wrapped in an appropriate subtype of `enclosing-condition-with-location': | |
abdf50aa MW |
159 | if the condition was a subtype of ERROR or WARNING then the resulting |
160 | condition will also be subtype of ERROR or WARNING as appropriate." | |
161 | ||
ad131652 MW |
162 | (labels ((check-no-args () |
163 | (unless (null arguments) | |
164 | (error "Argument list provided with specific condition"))) | |
165 | (wrap (condition) | |
abdf50aa | 166 | (make-condition |
388ab382 | 167 | (enclosing-condition-with-location-type condition) |
abdf50aa MW |
168 | :condition condition |
169 | :location (file-location floc))) | |
170 | (make (type &rest initargs) | |
171 | (if (subtypep type 'condition-with-location) | |
172 | (apply #'make-condition type | |
173 | :location (file-location floc) | |
174 | initargs) | |
175 | (wrap (apply #'make-condition type initargs))))) | |
ad131652 MW |
176 | (typecase datum |
177 | (condition-with-location (check-no-args) datum) | |
178 | (condition (check-no-args) (wrap datum)) | |
89ef4001 | 179 | (symbol (apply #'make datum arguments)) |
abdf50aa MW |
180 | ((or string function) (make default-type |
181 | :format-control datum | |
ad131652 MW |
182 | :format-arguments arguments)) |
183 | (t (error "Unexpected condition designator datum ~S" datum))))) | |
abdf50aa | 184 | |
dea4d055 | 185 | (export 'error-with-location) |
abdf50aa MW |
186 | (defun error-with-location (floc datum &rest arguments) |
187 | "Report an error with attached location information." | |
188 | (error (apply #'make-condition-with-location | |
189 | 'simple-error-with-location | |
190 | floc datum arguments))) | |
191 | ||
dea4d055 | 192 | (export 'warn-with-location) |
abdf50aa MW |
193 | (defun warn-with-location (floc datum &rest arguments) |
194 | "Report a warning with attached location information." | |
195 | (warn (apply #'make-condition-with-location | |
196 | 'simple-warning-with-location | |
197 | floc datum arguments))) | |
198 | ||
db6c3279 MW |
199 | (export 'info-with-location) |
200 | (defun info-with-location (floc datum &rest arguments) | |
201 | "Report some information with attached location information." | |
202 | (info (apply #'make-condition-with-location | |
203 | 'simple-information-with-location | |
204 | floc datum arguments))) | |
205 | ||
dea4d055 | 206 | (export 'cerror-with-location) |
abdf50aa MW |
207 | (defun cerror-with-location (floc continue-string datum &rest arguments) |
208 | "Report a continuable error with attached location information." | |
c884ec24 | 209 | (promiscuous-cerror continue-string |
9ec578d9 MW |
210 | (apply #'make-condition-with-location |
211 | 'simple-error-with-location | |
212 | floc datum arguments))) | |
abdf50aa | 213 | |
dea4d055 | 214 | (export 'cerror*-with-location) |
abdf50aa MW |
215 | (defun cerror*-with-location (floc datum &rest arguments) |
216 | (apply #'cerror-with-location floc "Continue" datum arguments)) | |
217 | ||
dea4d055 MW |
218 | ;;;-------------------------------------------------------------------------- |
219 | ;;; Stamping errors with location information. | |
220 | ||
016f25e4 | 221 | (let ((control-condition (make-condition 'condition))) |
8bb50d5d MW |
222 | (defun with-default-error-location* (floc thunk) |
223 | "Invoke THUNK in a dynamic environment which attaches FLOC to errors (and | |
224 | other conditions) which do not have file location information attached | |
225 | to them already. | |
226 | ||
227 | See the `with-default-error-location' macro for more details." | |
228 | ||
229 | (if floc | |
230 | (handler-bind | |
231 | ((condition-with-location | |
232 | (lambda (condition) | |
233 | (declare (ignore condition)) | |
234 | :decline)) | |
235 | (condition | |
236 | (lambda (condition) | |
237 | ||
238 | ;; The original condition may have restarts associated with | |
239 | ;; it. Find them and associate them with our new condition | |
240 | ;; when we signal that. For added fun, there isn't a | |
241 | ;; function to find just the associated restarts, or to find | |
242 | ;; out whether a restart is associated, so do this by making | |
243 | ;; up a control condition which has never been associated | |
244 | ;; with a restart. | |
245 | (let ((enclosing (make-condition-with-location nil floc | |
246 | condition))) | |
247 | (with-condition-restarts enclosing | |
248 | (set-difference (compute-restarts condition) | |
249 | (compute-restarts control-condition)) | |
250 | (signal enclosing)))))) | |
251 | (funcall thunk)) | |
252 | (funcall thunk)))) | |
dea4d055 MW |
253 | |
254 | (export 'with-default-error-location) | |
255 | (defmacro with-default-error-location ((floc) &body body) | |
256 | "Evaluate BODY, as an implicit progn, in a dynamic environment which | |
257 | attaches FLOC to errors (and other conditions) which do not have file | |
258 | location information attached to them already. | |
259 | ||
3109662a | 260 | If a condition other than a `condition-with-location' is signalled during |
dea4d055 | 261 | the evaluation of the BODY, then an instance of an appropriate subcalass |
3109662a | 262 | of `enclosing-condition-with-location' is constructed, enclosing the |
dea4d055 MW |
263 | original condition, and signalled. In particular, if the original |
264 | condition was a subtype of ERROR or WARNING, then the new condition will | |
265 | also be a subtype of ERROR or WARNING as appropriate. | |
266 | ||
3109662a | 267 | The FLOC argument is coerced to a `file-location' object each time a |
dea4d055 | 268 | condition is signalled. For example, if FLOC is a lexical analyser object |
3109662a MW |
269 | which reports its current position in response to `file-location', then |
270 | each condition will be reported as arising at the lexer's current position | |
271 | at that time, rather than all being reported at the same position. | |
dea4d055 MW |
272 | |
273 | If the new enclosing condition is not handled, the handler established by | |
274 | this macro will decline to handle the original condition. Typically, | |
3109662a | 275 | however, the new condition will be handled by `count-and-report-errors'. |
dea4d055 MW |
276 | |
277 | As a special case, if FLOC is nil, then no special action is taken, and | |
278 | BODY is simply evaluated, as an implicit progn." | |
279 | ||
280 | `(with-default-error-location* ,floc (lambda () ,@body))) | |
281 | ||
282 | ;;;-------------------------------------------------------------------------- | |
40d95de7 MW |
283 | ;;; Custom errors for parsers. |
284 | ||
285 | ;; Resolve dependency cycle. | |
286 | (export '(parser-error-expected parser-error-found)) | |
287 | (defgeneric parser-error-expected (condition)) | |
288 | (defgeneric parser-error-found (condition)) | |
289 | ||
290 | (export 'report-parser-error) | |
291 | (defun report-parser-error (error stream show-expected show-found) | |
292 | (format stream "~:[Unexpected~;~ | |
293 | Expected ~:*~{~#[~;~A~;~A or ~A~:;~ | |
294 | ~@{~A, ~#[~;or ~A~]~}~]~} but found~] ~ | |
295 | ~A" | |
296 | (mapcar show-expected (parser-error-expected error)) | |
297 | (funcall show-found (parser-error-found error)))) | |
298 | ||
299 | (export 'parser-error) | |
300 | (define-condition parser-error (error) | |
301 | ((expected :initarg :expected :reader parser-error-expected :type list) | |
302 | (found :initarg :found :reader parser-error-found :type t)) | |
303 | (:documentation "Standard error from a parser. | |
304 | ||
305 | Supports the usual kinds of parser failure, where the parser was expecting | |
306 | some kinds of things but found something else.") | |
307 | (:report (lambda (error stream) | |
308 | (report-parser-error error stream | |
309 | #'prin1-to-string #'prin1-to-string)))) | |
310 | ||
311 | (export '(base-lexer-error simple-lexer-error)) | |
312 | (define-condition base-lexer-error (error-with-location) ()) | |
313 | (define-condition simple-lexer-error | |
314 | (base-lexer-error simple-error-with-location) | |
315 | ()) | |
316 | ||
317 | (export '(base-syntax-error simple-syntax-error)) | |
318 | (define-condition base-syntax-error (error-with-location) ()) | |
319 | (define-condition simple-syntax-error | |
320 | (base-syntax-error simple-error-with-location) | |
321 | ()) | |
322 | ||
323 | ;;;-------------------------------------------------------------------------- | |
dea4d055 MW |
324 | ;;; Front-end error reporting. |
325 | ||
40d95de7 MW |
326 | (export 'classify-condition) |
327 | (defgeneric classify-condition (condition) | |
328 | (:method ((condition error)) "error") | |
329 | (:method ((condition base-lexer-error)) "lexical error") | |
330 | (:method ((condition base-syntax-error)) "syntax error") | |
331 | (:method ((condition warning)) "warning") | |
332 | (:method ((condition information)) "note")) | |
333 | ||
abdf50aa MW |
334 | (defun count-and-report-errors* (thunk) |
335 | "Invoke THUNK in a dynamic environment which traps and reports errors. | |
336 | ||
9ec578d9 | 337 | See the `count-and-report-errors' macro for more details." |
abdf50aa MW |
338 | |
339 | (let ((errors 0) | |
340 | (warnings 0)) | |
9ec578d9 MW |
341 | (restart-case |
342 | (let ((our-continue-restart (find-restart 'continue))) | |
40d95de7 MW |
343 | (flet ((report (condition &optional indicator) |
344 | (let ((*print-pretty* nil)) | |
345 | (format *error-output* | |
346 | "~&~A: ~@[~A ~]~A: ~A~%" | |
347 | (file-location condition) | |
348 | indicator (classify-condition condition) | |
349 | condition)))) | |
350 | (handler-bind | |
351 | ((error (lambda (error) | |
352 | (let ((fatal (eq (find-restart 'continue error) | |
353 | our-continue-restart))) | |
354 | (report error (and fatal "fatal")) | |
355 | (incf errors) | |
356 | (if fatal | |
357 | (return-from count-and-report-errors* | |
358 | (values nil errors warnings)) | |
359 | (continue error))))) | |
360 | (warning (lambda (warning) | |
361 | (report warning) | |
362 | (incf warnings) | |
363 | (muffle-warning warning))) | |
364 | (information (lambda (info) | |
365 | (report info) | |
366 | (noted info)))) | |
367 | (values (funcall thunk) | |
368 | errors | |
369 | warnings)))) | |
9ec578d9 MW |
370 | (continue () |
371 | :report (lambda (stream) (write-string "Exit to top-level" stream)) | |
372 | (values nil errors warnings))))) | |
abdf50aa | 373 | |
dea4d055 | 374 | (export 'count-and-report-errors) |
abdf50aa MW |
375 | (defmacro count-and-report-errors (() &body body) |
376 | "Evaluate BODY in a dynamic environment which traps and reports errors. | |
377 | ||
378 | The BODY is evaluated. If an error or warning is signalled, it is | |
379 | reported (using its report function), and counted. Warnings are otherwise | |
3109662a MW |
380 | muffled; continuable errors (i.e., when a `continue' restart is defined) |
381 | are continued; non-continuable errors cause an immediate exit from the | |
382 | BODY. | |
abdf50aa MW |
383 | |
384 | The final value consists of three values: the primary value of the BODY | |
3109662a | 385 | (or nil if a non-continuable error occurred), the number of errors |
abdf50aa MW |
386 | reported, and the number of warnings reported." |
387 | `(count-and-report-errors* (lambda () ,@body))) | |
388 | ||
abdf50aa | 389 | ;;;----- That's all, folks -------------------------------------------------- |