| 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 Sensble 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 &optional line column |
| 36 | &aux (filename |
| 37 | (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 | ;;; Enclosing conditions. |
| 58 | |
| 59 | (export '(enclosing-condition enclosed-condition)) |
| 60 | (define-condition enclosing-condition (condition) |
| 61 | ((%enclosed-condition :initarg :condition :type condition |
| 62 | :reader enclosed-condition)) |
| 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 |
| 68 | `enclosed-condition' function.") |
| 69 | (:report (lambda (condition stream) |
| 70 | (princ (enclosed-condition condition) stream)))) |
| 71 | |
| 72 | ;;;-------------------------------------------------------------------------- |
| 73 | ;;; Conditions with location information. |
| 74 | |
| 75 | (export 'condition-with-location) |
| 76 | (define-condition condition-with-location (condition) |
| 77 | ((location :initarg :location :reader file-location :type file-location)) |
| 78 | (:documentation |
| 79 | "A condition which has some location information attached.")) |
| 80 | |
| 81 | (export 'enclosing-condition-with-location) |
| 82 | (define-condition enclosing-condition-with-location |
| 83 | (condition-with-location enclosing-condition) |
| 84 | ()) |
| 85 | |
| 86 | (export 'error-with-location) |
| 87 | (define-condition error-with-location (condition-with-location error) |
| 88 | ()) |
| 89 | |
| 90 | (export 'warning-with-location) |
| 91 | (define-condition warning-with-location (condition-with-location warning) |
| 92 | ()) |
| 93 | |
| 94 | (export 'enclosing-error-with-location) |
| 95 | (define-condition enclosing-error-with-location |
| 96 | (enclosing-condition-with-location error) |
| 97 | ()) |
| 98 | |
| 99 | (export 'enclosing-warning-with-location) |
| 100 | (define-condition enclosing-warning-with-location |
| 101 | (enclosing-condition-with-location warning) |
| 102 | ()) |
| 103 | |
| 104 | (export 'simple-condition-with-location) |
| 105 | (define-condition simple-condition-with-location |
| 106 | (condition-with-location simple-condition) |
| 107 | ()) |
| 108 | |
| 109 | (export 'simple-error-with-location) |
| 110 | (define-condition simple-error-with-location |
| 111 | (error-with-location simple-error) |
| 112 | ()) |
| 113 | |
| 114 | (export 'simple-warning-with-location) |
| 115 | (define-condition simple-warning-with-location |
| 116 | (warning-with-location simple-warning) |
| 117 | ()) |
| 118 | |
| 119 | ;;;-------------------------------------------------------------------------- |
| 120 | ;;; Reporting errors. |
| 121 | |
| 122 | (export 'make-condition-with-location) |
| 123 | (defun make-condition-with-location (default-type floc datum &rest arguments) |
| 124 | "Construct a `condition-with-location' given a condition designator. |
| 125 | |
| 126 | The returned condition will always be a `condition-with-location'. The |
| 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 |
| 137 | `condition-with-location' then FLOC is attached as the location. |
| 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 |
| 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': |
| 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 | |
| 173 | (export 'error-with-location) |
| 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 | |
| 180 | (export 'warn-with-location) |
| 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 | |
| 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 | |
| 200 | (export 'cerror-with-location) |
| 201 | (defun cerror-with-location (floc continue-string datum &rest arguments) |
| 202 | "Report a continuable error with attached location information." |
| 203 | (my-cerror continue-string |
| 204 | (apply #'make-condition-with-location |
| 205 | 'simple-error-with-location |
| 206 | floc datum arguments))) |
| 207 | |
| 208 | (export 'cerror*) |
| 209 | (defun cerror* (datum &rest arguments) |
| 210 | (apply #'my-cerror "Continue" datum arguments)) |
| 211 | |
| 212 | (export 'cerror*-with-location) |
| 213 | (defun cerror*-with-location (floc datum &rest arguments) |
| 214 | (apply #'cerror-with-location floc "Continue" datum arguments)) |
| 215 | |
| 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 | |
| 224 | See the `with-default-error-location' macro for more details." |
| 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 | |
| 244 | If a condition other than a `condition-with-location' is signalled during |
| 245 | the evaluation of the BODY, then an instance of an appropriate subcalass |
| 246 | of `enclosing-condition-with-location' is constructed, enclosing the |
| 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 | |
| 251 | The FLOC argument is coerced to a `file-location' object each time a |
| 252 | condition is signalled. For example, if FLOC is a lexical analyser object |
| 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. |
| 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, |
| 259 | however, the new condition will be handled by `count-and-report-errors'. |
| 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 | |
| 269 | (defun count-and-report-errors* (thunk) |
| 270 | "Invoke THUNK in a dynamic environment which traps and reports errors. |
| 271 | |
| 272 | See the `count-and-report-errors' macro for more details." |
| 273 | |
| 274 | (let ((errors 0) |
| 275 | (warnings 0)) |
| 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))))) |
| 304 | |
| 305 | (export 'count-and-report-errors) |
| 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 |
| 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. |
| 314 | |
| 315 | The final value consists of three values: the primary value of the BODY |
| 316 | (or nil if a non-continuable error occurred), the number of errors |
| 317 | reported, and the number of warnings reported." |
| 318 | `(count-and-report-errors* (lambda () ,@body))) |
| 319 | |
| 320 | ;;;----- That's all, folks -------------------------------------------------- |