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 | ;;; | |
dea4d055 | 10 | ;;; This file is part of the Sensble 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 | ||
dea4d055 | 86 | (export 'error-with-location) |
abdf50aa MW |
87 | (define-condition error-with-location (condition-with-location error) |
88 | ()) | |
89 | ||
dea4d055 | 90 | (export 'warning-with-location) |
abdf50aa MW |
91 | (define-condition warning-with-location (condition-with-location warning) |
92 | ()) | |
93 | ||
dea4d055 | 94 | (export 'enclosing-error-with-location) |
abdf50aa MW |
95 | (define-condition enclosing-error-with-location |
96 | (enclosing-condition-with-location error) | |
97 | ()) | |
98 | ||
dea4d055 | 99 | (export 'enclosing-warning-with-location) |
abdf50aa MW |
100 | (define-condition enclosing-warning-with-location |
101 | (enclosing-condition-with-location warning) | |
102 | ()) | |
103 | ||
dea4d055 | 104 | (export 'simple-condition-with-location) |
abdf50aa MW |
105 | (define-condition simple-condition-with-location |
106 | (condition-with-location simple-condition) | |
107 | ()) | |
108 | ||
dea4d055 | 109 | (export 'simple-error-with-location) |
abdf50aa MW |
110 | (define-condition simple-error-with-location |
111 | (error-with-location simple-error) | |
112 | ()) | |
113 | ||
dea4d055 | 114 | (export 'simple-warning-with-location) |
abdf50aa MW |
115 | (define-condition simple-warning-with-location |
116 | (warning-with-location simple-warning) | |
117 | ()) | |
118 | ||
119 | ;;;-------------------------------------------------------------------------- | |
dea4d055 | 120 | ;;; Reporting errors. |
abdf50aa | 121 | |
dea4d055 | 122 | (export 'make-condition-with-location) |
abdf50aa | 123 | (defun make-condition-with-location (default-type floc datum &rest arguments) |
3109662a | 124 | "Construct a `condition-with-location' given a condition designator. |
abdf50aa | 125 | |
3109662a | 126 | The returned condition will always be a `condition-with-location'. The |
abdf50aa MW |
127 | process consists of two stages. In the first stage, a condition is |
128 | constructed from the condition designator DATUM and ARGUMENTS with default | |
129 | type DEFAULT-TYPE (a symbol). The precise behaviour depends on DATUM: | |
130 | ||
131 | * If DATUM is a condition, then it is used as-is; ARGUMENTS should be an | |
132 | empty list. | |
133 | ||
134 | * If DATUM is a symbol, then it must name a condition type. An instance | |
135 | of this class is constructed using ARGUMENTS as initargs, i.e., as | |
136 | if (apply #'make-condition ARGUMENTS); if the type is a subtype of | |
3109662a | 137 | `condition-with-location' then FLOC is attached as the location. |
abdf50aa MW |
138 | |
139 | * If DATUM is a format control (i.e., a string or function), then the | |
140 | condition is constructed as if, instead, DEFAULT-TYPE had been | |
141 | supplied as DATUM, and the list (:format-control DATUM | |
142 | :format-arguments ARGUMENTS) supplied as ARGUMENTS. | |
143 | ||
144 | In the second stage, the condition constructed by the first stage is | |
3109662a MW |
145 | converted into a `condition-with-location'. If the condition already has |
146 | type `condition-with-location' then it is returned as is. Otherwise it is | |
147 | wrapped in an appropriate subtype of `enclosing-condition-with-location': | |
abdf50aa MW |
148 | if the condition was a subtype of ERROR or WARNING then the resulting |
149 | condition will also be subtype of ERROR or WARNING as appropriate." | |
150 | ||
151 | (labels ((wrap (condition) | |
152 | (make-condition | |
153 | (etypecase condition | |
154 | (error 'enclosing-error-with-location) | |
155 | (warning 'enclosing-warning-with-location) | |
156 | (condition 'enclosing-condition-with-location)) | |
157 | :condition condition | |
158 | :location (file-location floc))) | |
159 | (make (type &rest initargs) | |
160 | (if (subtypep type 'condition-with-location) | |
161 | (apply #'make-condition type | |
162 | :location (file-location floc) | |
163 | initargs) | |
164 | (wrap (apply #'make-condition type initargs))))) | |
165 | (etypecase datum | |
166 | (condition-with-location datum) | |
167 | (condition (wrap datum)) | |
168 | (symbol (apply #'make arguments)) | |
169 | ((or string function) (make default-type | |
170 | :format-control datum | |
171 | :format-arguments arguments))))) | |
172 | ||
dea4d055 | 173 | (export 'error-with-location) |
abdf50aa MW |
174 | (defun error-with-location (floc datum &rest arguments) |
175 | "Report an error with attached location information." | |
176 | (error (apply #'make-condition-with-location | |
177 | 'simple-error-with-location | |
178 | floc datum arguments))) | |
179 | ||
dea4d055 | 180 | (export 'warn-with-location) |
abdf50aa MW |
181 | (defun warn-with-location (floc datum &rest arguments) |
182 | "Report a warning with attached location information." | |
183 | (warn (apply #'make-condition-with-location | |
184 | 'simple-warning-with-location | |
185 | floc datum arguments))) | |
186 | ||
9ec578d9 MW |
187 | (defun my-cerror (continue-string datum &rest arguments) |
188 | "Like standard `cerror', but robust against sneaky changes of conditions. | |
189 | ||
190 | It seems that `cerror' (well, at least the version in SBCL) is careful | |
191 | to limit its restart to the specific condition it signalled. But that's | |
192 | annoying, because `with-default-error-location' substitutes different | |
193 | conditions carrying the error-location information." | |
194 | (restart-case (apply #'error datum arguments) | |
195 | (continue () | |
196 | :report (lambda (stream) | |
197 | (apply #'format stream continue-string datum arguments)) | |
198 | nil))) | |
199 | ||
dea4d055 | 200 | (export 'cerror-with-location) |
abdf50aa MW |
201 | (defun cerror-with-location (floc continue-string datum &rest arguments) |
202 | "Report a continuable error with attached location information." | |
9ec578d9 MW |
203 | (my-cerror continue-string |
204 | (apply #'make-condition-with-location | |
205 | 'simple-error-with-location | |
206 | floc datum arguments))) | |
abdf50aa | 207 | |
dea4d055 | 208 | (export 'cerror*) |
abdf50aa | 209 | (defun cerror* (datum &rest arguments) |
9ec578d9 | 210 | (apply #'my-cerror "Continue" datum arguments)) |
abdf50aa | 211 | |
dea4d055 | 212 | (export 'cerror*-with-location) |
abdf50aa MW |
213 | (defun cerror*-with-location (floc datum &rest arguments) |
214 | (apply #'cerror-with-location floc "Continue" datum arguments)) | |
215 | ||
dea4d055 MW |
216 | ;;;-------------------------------------------------------------------------- |
217 | ;;; Stamping errors with location information. | |
218 | ||
219 | (defun with-default-error-location* (floc thunk) | |
220 | "Invoke THUNK in a dynamic environment which attaches FLOC to errors (and | |
221 | other conditions) which do not have file location information attached to | |
222 | them already. | |
223 | ||
3109662a | 224 | See the `with-default-error-location' macro for more details." |
dea4d055 MW |
225 | |
226 | (if floc | |
227 | (handler-bind | |
228 | ((condition-with-location | |
229 | (lambda (condition) | |
230 | (declare (ignore condition)) | |
231 | :decline)) | |
232 | (condition | |
233 | (lambda (condition) | |
234 | (signal (make-condition-with-location nil floc condition))))) | |
235 | (funcall thunk)) | |
236 | (funcall thunk))) | |
237 | ||
238 | (export 'with-default-error-location) | |
239 | (defmacro with-default-error-location ((floc) &body body) | |
240 | "Evaluate BODY, as an implicit progn, in a dynamic environment which | |
241 | attaches FLOC to errors (and other conditions) which do not have file | |
242 | location information attached to them already. | |
243 | ||
3109662a | 244 | If a condition other than a `condition-with-location' is signalled during |
dea4d055 | 245 | the evaluation of the BODY, then an instance of an appropriate subcalass |
3109662a | 246 | of `enclosing-condition-with-location' is constructed, enclosing the |
dea4d055 MW |
247 | original condition, and signalled. In particular, if the original |
248 | condition was a subtype of ERROR or WARNING, then the new condition will | |
249 | also be a subtype of ERROR or WARNING as appropriate. | |
250 | ||
3109662a | 251 | The FLOC argument is coerced to a `file-location' object each time a |
dea4d055 | 252 | condition is signalled. For example, if FLOC is a lexical analyser object |
3109662a MW |
253 | which reports its current position in response to `file-location', then |
254 | each condition will be reported as arising at the lexer's current position | |
255 | at that time, rather than all being reported at the same position. | |
dea4d055 MW |
256 | |
257 | If the new enclosing condition is not handled, the handler established by | |
258 | this macro will decline to handle the original condition. Typically, | |
3109662a | 259 | however, the new condition will be handled by `count-and-report-errors'. |
dea4d055 MW |
260 | |
261 | As a special case, if FLOC is nil, then no special action is taken, and | |
262 | BODY is simply evaluated, as an implicit progn." | |
263 | ||
264 | `(with-default-error-location* ,floc (lambda () ,@body))) | |
265 | ||
266 | ;;;-------------------------------------------------------------------------- | |
267 | ;;; Front-end error reporting. | |
268 | ||
abdf50aa MW |
269 | (defun count-and-report-errors* (thunk) |
270 | "Invoke THUNK in a dynamic environment which traps and reports errors. | |
271 | ||
9ec578d9 | 272 | See the `count-and-report-errors' macro for more details." |
abdf50aa MW |
273 | |
274 | (let ((errors 0) | |
275 | (warnings 0)) | |
9ec578d9 MW |
276 | (restart-case |
277 | (let ((our-continue-restart (find-restart 'continue))) | |
278 | (handler-bind | |
279 | ((error (lambda (error) | |
280 | (let ((fatal (eq (find-restart 'continue error) | |
281 | our-continue-restart))) | |
282 | (format *error-output* | |
283 | "~&~A: ~:[~;Fatal error: ~]~A~%" | |
284 | (file-location error) | |
285 | fatal | |
286 | error) | |
287 | (incf errors) | |
288 | (if fatal | |
289 | (return-from count-and-report-errors* | |
290 | (values nil errors warnings)) | |
291 | (invoke-restart 'continue))))) | |
292 | (warning (lambda (warning) | |
293 | (format *error-output* "~&~A: Warning: ~A~%" | |
294 | (file-location warning) | |
295 | warning) | |
296 | (incf warnings) | |
297 | (invoke-restart 'muffle-warning)))) | |
298 | (values (funcall thunk) | |
299 | errors | |
300 | warnings))) | |
301 | (continue () | |
302 | :report (lambda (stream) (write-string "Exit to top-level" stream)) | |
303 | (values nil errors warnings))))) | |
abdf50aa | 304 | |
dea4d055 | 305 | (export 'count-and-report-errors) |
abdf50aa MW |
306 | (defmacro count-and-report-errors (() &body body) |
307 | "Evaluate BODY in a dynamic environment which traps and reports errors. | |
308 | ||
309 | The BODY is evaluated. If an error or warning is signalled, it is | |
310 | reported (using its report function), and counted. Warnings are otherwise | |
3109662a MW |
311 | muffled; continuable errors (i.e., when a `continue' restart is defined) |
312 | are continued; non-continuable errors cause an immediate exit from the | |
313 | BODY. | |
abdf50aa MW |
314 | |
315 | The final value consists of three values: the primary value of the BODY | |
3109662a | 316 | (or nil if a non-continuable error occurred), the number of errors |
abdf50aa MW |
317 | reported, and the number of warnings reported." |
318 | `(count-and-report-errors* (lambda () ,@body))) | |
319 | ||
abdf50aa | 320 | ;;;----- That's all, folks -------------------------------------------------- |