3 ;;; Protocol for file locations
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensible Object Design, an object system for C.
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.
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.
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.
26 (cl:in-package #:sod-parser)
28 ;;;--------------------------------------------------------------------------
29 ;;; File location objects.
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
35 (%filename &optional line column
38 ((or string null) %filename)
39 (pathname (namestring %filename)))))))
40 "A simple structure containing file location information.
42 Construct using `make-file-location'; the main useful function is
43 `error-file-location'."
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))
48 (defgeneric file-location (thing)
50 "Convert THING into a `file-location', if possible.
52 A THING which can be converted into a `file-location' is termed a
53 `file-location designator'.")
54 (:method ((thing file-location)) thing))
56 ;;;--------------------------------------------------------------------------
57 ;;; Enclosing conditions.
59 (export '(enclosing-condition enclosed-condition))
60 (define-condition enclosing-condition (condition)
61 ((%enclosed-condition :initarg :condition :type condition
62 :reader enclosed-condition))
64 "A condition which encloses another condition
66 This is useful if one wants to attach additional information to an
67 existing condition. The enclosed condition can be obtained using the
68 `enclosed-condition' function.")
69 (:report (lambda (condition stream)
70 (princ (enclosed-condition condition) stream))))
72 ;;;--------------------------------------------------------------------------
73 ;;; Conditions with location information.
75 (export 'condition-with-location)
76 (define-condition condition-with-location (condition)
77 ((location :initarg :location :reader file-location :type file-location))
79 "A condition which has some location information attached."))
81 (export 'enclosing-condition-with-location)
82 (define-condition enclosing-condition-with-location
83 (condition-with-location enclosing-condition)
87 (define-condition information (condition)
90 (export 'error-with-location)
91 (define-condition error-with-location (condition-with-location error)
94 (export 'warning-with-location)
95 (define-condition warning-with-location (condition-with-location warning)
98 (export 'information-with-location)
99 (define-condition information-with-location
100 (condition-with-location information)
103 (export 'enclosing-error-with-location)
104 (define-condition enclosing-error-with-location
105 (enclosing-condition-with-location error)
108 (export 'enclosing-warning-with-location)
109 (define-condition enclosing-warning-with-location
110 (enclosing-condition-with-location warning)
113 (export 'enclosing-information-with-location)
114 (define-condition enclosing-information-with-location
115 (enclosing-condition-with-location information)
118 (export 'simple-condition-with-location)
119 (define-condition simple-condition-with-location
120 (condition-with-location simple-condition)
123 (export 'simple-error-with-location)
124 (define-condition simple-error-with-location
125 (error-with-location simple-error)
128 (export 'simple-warning-with-location)
129 (define-condition simple-warning-with-location
130 (warning-with-location simple-warning)
133 (export 'simple-information)
134 (define-condition simple-information (simple-condition information)
138 (defun info (datum &rest arguments)
139 "Report some useful diagnostic information.
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."
145 (signal (designated-condition 'simple-information datum arguments))
146 (noted () :report "Noted." t)))
149 (defun noted (&optional condition)
150 "Invoke the `noted' restart, possibly associated with the given CONDITION."
151 (invoke-associated-restart 'noted condition))
153 (export 'simple-information-with-location)
154 (define-condition simple-information-with-location
155 (information-with-location simple-information)
158 ;;;--------------------------------------------------------------------------
159 ;;; Reporting errors.
161 (export 'enclosing-condition-with-location-type)
162 (defgeneric enclosing-condition-with-location-type (condition)
164 "Return a class suitable for attaching location information to CONDITION.
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)
170 (:method ((condition information)) 'enclosing-information-with-location)
171 (:method ((condition condition)) 'enclosing-condition-with-location))
173 (export 'make-condition-with-location)
174 (defun make-condition-with-location (default-type floc datum &rest arguments)
175 "Construct a `condition-with-location' given a condition designator.
177 The returned condition will always be a `condition-with-location'. The
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:
182 * If DATUM is a condition, then it is used as-is; ARGUMENTS should be an
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
188 `condition-with-location' then FLOC is attached as the location.
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.
195 In the second stage, the condition constructed by the first stage is
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':
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."
202 (labels ((check-no-args ()
203 (unless (null arguments)
204 (error "Argument list provided with specific condition")))
207 (enclosing-condition-with-location-type 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)
215 (wrap (apply #'make-condition type initargs)))))
217 (condition-with-location (check-no-args) datum)
218 (condition (check-no-args) (wrap datum))
219 (symbol (apply #'make datum arguments))
220 ((or string function) (make default-type
221 :format-control datum
222 :format-arguments arguments))
223 (t (error "Unexpected condition designator datum ~S" datum)))))
225 (export 'error-with-location)
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)))
232 (export 'warn-with-location)
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)))
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)))
246 (defun my-cerror (continue-string datum &rest arguments)
247 "Like standard `cerror', but robust against sneaky changes of conditions.
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)
255 :report (lambda (stream)
256 (apply #'format stream continue-string datum arguments))
259 (export 'cerror-with-location)
260 (defun cerror-with-location (floc continue-string datum &rest arguments)
261 "Report a continuable error with attached location information."
262 (my-cerror continue-string
263 (apply #'make-condition-with-location
264 'simple-error-with-location
265 floc datum arguments)))
268 (defun cerror* (datum &rest arguments)
269 (apply #'my-cerror "Continue" datum arguments))
271 (export 'cerror*-with-location)
272 (defun cerror*-with-location (floc datum &rest arguments)
273 (apply #'cerror-with-location floc "Continue" datum arguments))
275 ;;;--------------------------------------------------------------------------
276 ;;; Stamping errors with location information.
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
283 See the `with-default-error-location' macro for more details."
287 ((condition-with-location
289 (declare (ignore condition))
293 (signal (make-condition-with-location nil floc condition)))))
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.
303 If a condition other than a `condition-with-location' is signalled during
304 the evaluation of the BODY, then an instance of an appropriate subcalass
305 of `enclosing-condition-with-location' is constructed, enclosing the
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.
310 The FLOC argument is coerced to a `file-location' object each time a
311 condition is signalled. For example, if FLOC is a lexical analyser object
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.
316 If the new enclosing condition is not handled, the handler established by
317 this macro will decline to handle the original condition. Typically,
318 however, the new condition will be handled by `count-and-report-errors'.
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."
323 `(with-default-error-location* ,floc (lambda () ,@body)))
325 ;;;--------------------------------------------------------------------------
326 ;;; Custom errors for parsers.
328 ;; Resolve dependency cycle.
329 (export '(parser-error-expected parser-error-found))
330 (defgeneric parser-error-expected (condition))
331 (defgeneric parser-error-found (condition))
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~] ~
339 (mapcar show-expected (parser-error-expected error))
340 (funcall show-found (parser-error-found error))))
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.
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))))
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)
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)
366 ;;;--------------------------------------------------------------------------
367 ;;; Front-end error reporting.
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"))
377 (defun count-and-report-errors* (thunk)
378 "Invoke THUNK in a dynamic environment which traps and reports errors.
380 See the `count-and-report-errors' macro for more details."
385 (let ((our-continue-restart (find-restart 'continue)))
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)
394 ((error (lambda (error)
395 (let ((fatal (eq (find-restart 'continue error)
396 our-continue-restart)))
397 (report error (and fatal "fatal"))
400 (return-from count-and-report-errors*
401 (values nil errors warnings))
403 (warning (lambda (warning)
406 (muffle-warning warning)))
407 (information (lambda (info)
410 (values (funcall thunk)
414 :report (lambda (stream) (write-string "Exit to top-level" stream))
415 (values nil errors warnings)))))
417 (export 'count-and-report-errors)
418 (defmacro count-and-report-errors (() &body body)
419 "Evaluate BODY in a dynamic environment which traps and reports errors.
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
423 muffled; continuable errors (i.e., when a `continue' restart is defined)
424 are continued; non-continuable errors cause an immediate exit from the
427 The final value consists of three values: the primary value of the BODY
428 (or nil if a non-continuable error occurred), the number of errors
429 reported, and the number of warnings reported."
430 `(count-and-report-errors* (lambda () ,@body)))
432 ;;;----- That's all, folks --------------------------------------------------