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
37 &aux (filename (etypecase %filename
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 ;;; Conditions with location information.
59 (export 'condition-with-location)
60 (define-condition condition-with-location (condition)
61 ((location :initarg :location :reader file-location :type file-location))
63 "A condition which has some location information attached."))
65 (export 'enclosing-condition-with-location)
66 (define-condition enclosing-condition-with-location
67 (condition-with-location enclosing-condition)
70 (export 'error-with-location)
71 (define-condition error-with-location (condition-with-location error)
74 (export 'warning-with-location)
75 (define-condition warning-with-location (condition-with-location warning)
78 (export 'information-with-location)
79 (define-condition information-with-location
80 (condition-with-location information)
83 (export 'enclosing-error-with-location)
84 (define-condition enclosing-error-with-location
85 (enclosing-condition-with-location error)
88 (export 'enclosing-warning-with-location)
89 (define-condition enclosing-warning-with-location
90 (enclosing-condition-with-location warning)
93 (export 'enclosing-information-with-location)
94 (define-condition enclosing-information-with-location
95 (enclosing-condition-with-location information)
98 (export 'simple-condition-with-location)
99 (define-condition simple-condition-with-location
100 (condition-with-location simple-condition)
103 (export 'simple-error-with-location)
104 (define-condition simple-error-with-location
105 (error-with-location simple-error)
108 (export 'simple-warning-with-location)
109 (define-condition simple-warning-with-location
110 (warning-with-location simple-warning)
113 (export 'simple-information-with-location)
114 (define-condition simple-information-with-location
115 (information-with-location simple-information)
118 ;;;--------------------------------------------------------------------------
119 ;;; Reporting errors.
121 (export 'enclosing-condition-with-location-type)
122 (defgeneric enclosing-condition-with-location-type (condition)
124 "Return a class suitable for attaching location information to CONDITION.
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)
130 (:method ((condition information)) 'enclosing-information-with-location)
131 (:method ((condition condition)) 'enclosing-condition-with-location))
133 (export 'make-condition-with-location)
134 (defun make-condition-with-location (default-type floc datum &rest arguments)
135 "Construct a `condition-with-location' given a condition designator.
137 The returned condition will always be a `condition-with-location'. The
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:
142 * If DATUM is a condition, then it is used as-is; ARGUMENTS should be an
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
148 `condition-with-location' then FLOC is attached as the location.
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.
155 In the second stage, the condition constructed by the first stage is
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':
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."
162 (labels ((check-no-args ()
163 (unless (null arguments)
164 (error "Argument list provided with specific condition")))
167 (enclosing-condition-with-location-type 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)
175 (wrap (apply #'make-condition type initargs)))))
177 (condition-with-location (check-no-args) datum)
178 (condition (check-no-args) (wrap datum))
179 (symbol (apply #'make datum arguments))
180 ((or string function) (make default-type
181 :format-control datum
182 :format-arguments arguments))
183 (t (error "Unexpected condition designator datum ~S" datum)))))
185 (export 'error-with-location)
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)))
192 (export 'warn-with-location)
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)))
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)))
206 (export 'cerror-with-location)
207 (defun cerror-with-location (floc continue-string datum &rest arguments)
208 "Report a continuable error with attached location information."
209 (promiscuous-cerror continue-string
210 (apply #'make-condition-with-location
211 'simple-error-with-location
212 floc datum arguments)))
214 (export 'cerror*-with-location)
215 (defun cerror*-with-location (floc datum &rest arguments)
216 (apply #'cerror-with-location floc "Continue" datum arguments))
218 ;;;--------------------------------------------------------------------------
219 ;;; Stamping errors with location information.
221 (let ((control-condition (make-instance 'condition)))
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
227 See the `with-default-error-location' macro for more details."
231 ((condition-with-location
233 (declare (ignore condition))
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
245 (let ((enclosing (make-condition-with-location nil floc
247 (with-condition-restarts enclosing
248 (set-difference (compute-restarts condition)
249 (compute-restarts control-condition))
250 (signal enclosing))))))
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.
260 If a condition other than a `condition-with-location' is signalled during
261 the evaluation of the BODY, then an instance of an appropriate subcalass
262 of `enclosing-condition-with-location' is constructed, enclosing the
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.
267 The FLOC argument is coerced to a `file-location' object each time a
268 condition is signalled. For example, if FLOC is a lexical analyser object
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.
273 If the new enclosing condition is not handled, the handler established by
274 this macro will decline to handle the original condition. Typically,
275 however, the new condition will be handled by `count-and-report-errors'.
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."
280 `(with-default-error-location* ,floc (lambda () ,@body)))
282 ;;;--------------------------------------------------------------------------
283 ;;; Custom errors for parsers.
285 ;; Resolve dependency cycle.
286 (export '(parser-error-expected parser-error-found))
287 (defgeneric parser-error-expected (condition))
288 (defgeneric parser-error-found (condition))
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~] ~
296 (mapcar show-expected (parser-error-expected error))
297 (funcall show-found (parser-error-found error))))
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.
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))))
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)
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)
323 ;;;--------------------------------------------------------------------------
324 ;;; Front-end error reporting.
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"))
334 (defun count-and-report-errors* (thunk)
335 "Invoke THUNK in a dynamic environment which traps and reports errors.
337 See the `count-and-report-errors' macro for more details."
342 (let ((our-continue-restart (find-restart 'continue)))
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)
351 ((error (lambda (error)
352 (let ((fatal (eq (find-restart 'continue error)
353 our-continue-restart)))
354 (report error (and fatal "fatal"))
357 (return-from count-and-report-errors*
358 (values nil errors warnings))
360 (warning (lambda (warning)
363 (muffle-warning warning)))
364 (information (lambda (info)
367 (values (funcall thunk)
371 :report (lambda (stream) (write-string "Exit to top-level" stream))
372 (values nil errors warnings)))))
374 (export 'count-and-report-errors)
375 (defmacro count-and-report-errors (() &body body)
376 "Evaluate BODY in a dynamic environment which traps and reports errors.
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
380 muffled; continuable errors (i.e., when a `continue' restart is defined)
381 are continued; non-continuable errors cause an immediate exit from the
384 The final value consists of three values: the primary value of the BODY
385 (or nil if a non-continuable error occurred), the number of errors
386 reported, and the number of warnings reported."
387 `(count-and-report-errors* (lambda () ,@body)))
389 ;;;----- That's all, folks --------------------------------------------------