| 1 | ;;; -*-lisp-*- |
| 2 | ;;; |
| 3 | ;;; Protocol for file locations |
| 4 | ;;; |
| 5 | ;;; (c) 2009 Straylight/Edgeware |
| 6 | ;;; |
| 7 | |
| 8 | ;;;----- Licensing notice --------------------------------------------------- |
| 9 | ;;; |
| 10 | ;;; This file is part of the Sensible Object Design, an object system for C. |
| 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 | |
| 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 |
| 35 | (%filename |
| 36 | &optional line column |
| 37 | &aux (filename (etypecase %filename |
| 38 | ((or string null) %filename) |
| 39 | (pathname (namestring %filename))))))) |
| 40 | "A simple structure containing file location information. |
| 41 | |
| 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)) |
| 47 | |
| 48 | (defgeneric file-location (thing) |
| 49 | (:documentation |
| 50 | "Convert THING into a `file-location', if possible. |
| 51 | |
| 52 | A THING which can be converted into a `file-location' is termed a |
| 53 | `file-location designator'.") |
| 54 | (:method ((thing file-location)) thing)) |
| 55 | |
| 56 | ;;;-------------------------------------------------------------------------- |
| 57 | ;;; Conditions with location information. |
| 58 | |
| 59 | (export 'condition-with-location) |
| 60 | (define-condition condition-with-location (condition) |
| 61 | ((location :initarg :location :reader file-location :type file-location)) |
| 62 | (:documentation |
| 63 | "A condition which has some location information attached.")) |
| 64 | |
| 65 | (export 'enclosing-condition-with-location) |
| 66 | (define-condition enclosing-condition-with-location |
| 67 | (condition-with-location enclosing-condition) |
| 68 | ()) |
| 69 | |
| 70 | (export 'error-with-location) |
| 71 | (define-condition error-with-location (condition-with-location error) |
| 72 | ()) |
| 73 | |
| 74 | (export 'warning-with-location) |
| 75 | (define-condition warning-with-location (condition-with-location warning) |
| 76 | ()) |
| 77 | |
| 78 | (export 'information-with-location) |
| 79 | (define-condition information-with-location |
| 80 | (condition-with-location information) |
| 81 | ()) |
| 82 | |
| 83 | (export 'enclosing-error-with-location) |
| 84 | (define-condition enclosing-error-with-location |
| 85 | (enclosing-condition-with-location error) |
| 86 | ()) |
| 87 | |
| 88 | (export 'enclosing-warning-with-location) |
| 89 | (define-condition enclosing-warning-with-location |
| 90 | (enclosing-condition-with-location warning) |
| 91 | ()) |
| 92 | |
| 93 | (export 'enclosing-information-with-location) |
| 94 | (define-condition enclosing-information-with-location |
| 95 | (enclosing-condition-with-location information) |
| 96 | ()) |
| 97 | |
| 98 | (export 'simple-condition-with-location) |
| 99 | (define-condition simple-condition-with-location |
| 100 | (condition-with-location simple-condition) |
| 101 | ()) |
| 102 | |
| 103 | (export 'simple-error-with-location) |
| 104 | (define-condition simple-error-with-location |
| 105 | (error-with-location simple-error) |
| 106 | ()) |
| 107 | |
| 108 | (export 'simple-warning-with-location) |
| 109 | (define-condition simple-warning-with-location |
| 110 | (warning-with-location simple-warning) |
| 111 | ()) |
| 112 | |
| 113 | (export 'simple-information-with-location) |
| 114 | (define-condition simple-information-with-location |
| 115 | (information-with-location simple-information) |
| 116 | ()) |
| 117 | |
| 118 | ;;;-------------------------------------------------------------------------- |
| 119 | ;;; Reporting errors. |
| 120 | |
| 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) |
| 130 | (:method ((condition information)) 'enclosing-information-with-location) |
| 131 | (:method ((condition condition)) 'enclosing-condition-with-location)) |
| 132 | |
| 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. |
| 136 | |
| 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: |
| 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 |
| 148 | `condition-with-location' then FLOC is attached as the location. |
| 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 |
| 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." |
| 161 | |
| 162 | (labels ((check-no-args () |
| 163 | (unless (null arguments) |
| 164 | (error "Argument list provided with specific condition"))) |
| 165 | (wrap (condition) |
| 166 | (make-condition |
| 167 | (enclosing-condition-with-location-type condition) |
| 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))))) |
| 176 | (typecase datum |
| 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))))) |
| 184 | |
| 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))) |
| 191 | |
| 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))) |
| 198 | |
| 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 | |
| 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))) |
| 213 | |
| 214 | (export 'cerror*-with-location) |
| 215 | (defun cerror*-with-location (floc datum &rest arguments) |
| 216 | (apply #'cerror-with-location floc "Continue" datum arguments)) |
| 217 | |
| 218 | ;;;-------------------------------------------------------------------------- |
| 219 | ;;; Stamping errors with location information. |
| 220 | |
| 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 |
| 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)))) |
| 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 | |
| 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. |
| 266 | |
| 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. |
| 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, |
| 275 | however, the new condition will be handled by `count-and-report-errors'. |
| 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 | ;;;-------------------------------------------------------------------------- |
| 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 | ;;;-------------------------------------------------------------------------- |
| 324 | ;;; Front-end error reporting. |
| 325 | |
| 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 | |
| 334 | (defun count-and-report-errors* (thunk) |
| 335 | "Invoke THUNK in a dynamic environment which traps and reports errors. |
| 336 | |
| 337 | See the `count-and-report-errors' macro for more details." |
| 338 | |
| 339 | (let ((errors 0) |
| 340 | (warnings 0)) |
| 341 | (restart-case |
| 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) |
| 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)))) |
| 370 | (continue () |
| 371 | :report (lambda (stream) (write-string "Exit to top-level" stream)) |
| 372 | (values nil errors warnings))))) |
| 373 | |
| 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. |
| 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 |
| 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. |
| 383 | |
| 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))) |
| 388 | |
| 389 | ;;;----- That's all, folks -------------------------------------------------- |