| 1 | ;;; -*-lisp-*- |
| 2 | ;;; |
| 3 | ;;; Error types and handling utilities |
| 4 | ;;; |
| 5 | ;;; (c) 2009 Straylight/Edgeware |
| 6 | ;;; |
| 7 | |
| 8 | ;;;----- Licensing notice --------------------------------------------------- |
| 9 | ;;; |
| 10 | ;;; This file is part of the Simple Object Definition system. |
| 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) |
| 27 | |
| 28 | ;;;-------------------------------------------------------------------------- |
| 29 | ;;; Enclosing conditions. |
| 30 | |
| 31 | (define-condition enclosing-condition (condition) |
| 32 | ((enclosed-condition :initarg :condition :type condition |
| 33 | :reader enclosed-condition)) |
| 34 | (:documentation |
| 35 | "A condition which encloses another condition |
| 36 | |
| 37 | This is useful if one wants to attach additional information to an |
| 38 | existing condition. The enclosed condition can be obtained using the |
| 39 | ENCLOSED-CONDITION function.") |
| 40 | (:report (lambda (condition stream) |
| 41 | (princ (enclosed-condition condition) stream)))) |
| 42 | |
| 43 | ;;;-------------------------------------------------------------------------- |
| 44 | ;;; Conditions with location information. |
| 45 | |
| 46 | (define-condition condition-with-location (condition) |
| 47 | ((location :initarg :location :reader file-location :type file-location)) |
| 48 | (:documentation |
| 49 | "A condition which has some location information attached.")) |
| 50 | |
| 51 | (define-condition enclosing-condition-with-location |
| 52 | (condition-with-location enclosing-condition) |
| 53 | ()) |
| 54 | |
| 55 | (define-condition error-with-location (condition-with-location error) |
| 56 | ()) |
| 57 | |
| 58 | (define-condition warning-with-location (condition-with-location warning) |
| 59 | ()) |
| 60 | |
| 61 | (define-condition enclosing-error-with-location |
| 62 | (enclosing-condition-with-location error) |
| 63 | ()) |
| 64 | |
| 65 | (define-condition enclosing-warning-with-location |
| 66 | (enclosing-condition-with-location warning) |
| 67 | ()) |
| 68 | |
| 69 | (define-condition simple-condition-with-location |
| 70 | (condition-with-location simple-condition) |
| 71 | ()) |
| 72 | |
| 73 | (define-condition simple-error-with-location |
| 74 | (error-with-location simple-error) |
| 75 | ()) |
| 76 | |
| 77 | (define-condition simple-warning-with-location |
| 78 | (warning-with-location simple-warning) |
| 79 | ()) |
| 80 | |
| 81 | ;;;-------------------------------------------------------------------------- |
| 82 | ;;; Error reporting functions. |
| 83 | |
| 84 | (defun make-condition-with-location (default-type floc datum &rest arguments) |
| 85 | "Construct a CONDITION-WITH-LOCATION given a condition designator. |
| 86 | |
| 87 | The returned condition will always be a CONDITION-WITH-LOCATION. The |
| 88 | process consists of two stages. In the first stage, a condition is |
| 89 | constructed from the condition designator DATUM and ARGUMENTS with default |
| 90 | type DEFAULT-TYPE (a symbol). The precise behaviour depends on DATUM: |
| 91 | |
| 92 | * If DATUM is a condition, then it is used as-is; ARGUMENTS should be an |
| 93 | empty list. |
| 94 | |
| 95 | * If DATUM is a symbol, then it must name a condition type. An instance |
| 96 | of this class is constructed using ARGUMENTS as initargs, i.e., as |
| 97 | if (apply #'make-condition ARGUMENTS); if the type is a subtype of |
| 98 | CONDITION-WITH-LOCATION then FLOC is attached as the location. |
| 99 | |
| 100 | * If DATUM is a format control (i.e., a string or function), then the |
| 101 | condition is constructed as if, instead, DEFAULT-TYPE had been |
| 102 | supplied as DATUM, and the list (:format-control DATUM |
| 103 | :format-arguments ARGUMENTS) supplied as ARGUMENTS. |
| 104 | |
| 105 | In the second stage, the condition constructed by the first stage is |
| 106 | converted into a CONDITION-WITH-LOCATION. If the condition already has |
| 107 | type CONDITION-WITH-LOCATION then it is returned as is. Otherwise it is |
| 108 | wrapped in an appropriate subtype of ENCLOSING-CONDITION-WITH-LOCATION: |
| 109 | if the condition was a subtype of ERROR or WARNING then the resulting |
| 110 | condition will also be subtype of ERROR or WARNING as appropriate." |
| 111 | |
| 112 | (labels ((wrap (condition) |
| 113 | (make-condition |
| 114 | (etypecase condition |
| 115 | (error 'enclosing-error-with-location) |
| 116 | (warning 'enclosing-warning-with-location) |
| 117 | (condition 'enclosing-condition-with-location)) |
| 118 | :condition condition |
| 119 | :location (file-location floc))) |
| 120 | (make (type &rest initargs) |
| 121 | (if (subtypep type 'condition-with-location) |
| 122 | (apply #'make-condition type |
| 123 | :location (file-location floc) |
| 124 | initargs) |
| 125 | (wrap (apply #'make-condition type initargs))))) |
| 126 | (etypecase datum |
| 127 | (condition-with-location datum) |
| 128 | (condition (wrap datum)) |
| 129 | (symbol (apply #'make arguments)) |
| 130 | ((or string function) (make default-type |
| 131 | :format-control datum |
| 132 | :format-arguments arguments))))) |
| 133 | |
| 134 | (defun error-with-location (floc datum &rest arguments) |
| 135 | "Report an error with attached location information." |
| 136 | (error (apply #'make-condition-with-location |
| 137 | 'simple-error-with-location |
| 138 | floc datum arguments))) |
| 139 | |
| 140 | (defun warn-with-location (floc datum &rest arguments) |
| 141 | "Report a warning with attached location information." |
| 142 | (warn (apply #'make-condition-with-location |
| 143 | 'simple-warning-with-location |
| 144 | floc datum arguments))) |
| 145 | |
| 146 | (defun cerror-with-location (floc continue-string datum &rest arguments) |
| 147 | "Report a continuable error with attached location information." |
| 148 | (cerror continue-string |
| 149 | (apply #'make-condition-with-location |
| 150 | 'simple-error-with-location |
| 151 | floc datum arguments))) |
| 152 | |
| 153 | (defun cerror* (datum &rest arguments) |
| 154 | (apply #'cerror "Continue" datum arguments)) |
| 155 | |
| 156 | (defun cerror*-with-location (floc datum &rest arguments) |
| 157 | (apply #'cerror-with-location floc "Continue" datum arguments)) |
| 158 | |
| 159 | (defun count-and-report-errors* (thunk) |
| 160 | "Invoke THUNK in a dynamic environment which traps and reports errors. |
| 161 | |
| 162 | See the COUNT-AND-REPORT-ERRORS macro for more detais." |
| 163 | |
| 164 | (let ((errors 0) |
| 165 | (warnings 0)) |
| 166 | (handler-bind |
| 167 | ((error (lambda (error) |
| 168 | (let ((fatal (not (find-restart 'continue error)))) |
| 169 | (format *error-output* "~&~A: ~:[~;Fatal error: ~]~A~%" |
| 170 | (file-location error) |
| 171 | fatal |
| 172 | error) |
| 173 | (incf errors) |
| 174 | (if fatal |
| 175 | (return-from count-and-report-errors* |
| 176 | (values nil errors warnings)) |
| 177 | (invoke-restart 'continue))))) |
| 178 | (warning (lambda (warning) |
| 179 | (format *error-output* "~&~A: Warning: ~A~%" |
| 180 | (file-location warning) |
| 181 | warning) |
| 182 | (incf warnings) |
| 183 | (invoke-restart 'muffle-warning)))) |
| 184 | (values (funcall thunk) |
| 185 | errors |
| 186 | warnings)))) |
| 187 | |
| 188 | (defmacro count-and-report-errors (() &body body) |
| 189 | "Evaluate BODY in a dynamic environment which traps and reports errors. |
| 190 | |
| 191 | The BODY is evaluated. If an error or warning is signalled, it is |
| 192 | reported (using its report function), and counted. Warnings are otherwise |
| 193 | muffled; continuable errors (i.e., when a CONTINUE restart is defined) are |
| 194 | continued; non-continuable errors cause an immediate exit from the BODY. |
| 195 | |
| 196 | The final value consists of three values: the primary value of the BODY |
| 197 | (or NIL if a non-continuable error occurred), the number of errors |
| 198 | reported, and the number of warnings reported." |
| 199 | `(count-and-report-errors* (lambda () ,@body))) |
| 200 | |
| 201 | (defun with-default-error-location* (floc thunk) |
| 202 | "Invoke THUNK in a dynamic environment which attaches FLOC to errors (and |
| 203 | other conditions) which do not have file location information attached to |
| 204 | them already. |
| 205 | |
| 206 | See the WITH-DEFAULT-ERROR-LOCATION macro for more details." |
| 207 | |
| 208 | (if floc |
| 209 | (handler-bind |
| 210 | ((condition-with-location (lambda (condition) |
| 211 | (declare (ignore condition)) |
| 212 | :decline)) |
| 213 | (condition (lambda (condition) |
| 214 | (signal (make-condition-with-location nil |
| 215 | floc |
| 216 | condition))))) |
| 217 | (funcall thunk)) |
| 218 | (funcall thunk))) |
| 219 | |
| 220 | (defmacro with-default-error-location ((floc) &body body) |
| 221 | "Evaluate BODY in a dynamic environment which attaches FLOC to errors (and |
| 222 | other conditions) which do not have file location information attached to |
| 223 | them already. |
| 224 | |
| 225 | If a condition other than a CONDITION-WITH-LOCATION is signalled during |
| 226 | the evaluation of the BODY, then an instance of an appropriate subtype of |
| 227 | ENCLOSING-CONDITION-WITH-LOCATION is constructed, enclosing the original |
| 228 | condition, and signalled. If the original condition was a subtype of |
| 229 | ERROR or WARNING, then the new condition will also be a subtype of ERROR |
| 230 | or WARNING as appropriate. |
| 231 | |
| 232 | The FLOC argument is coerced to a FILE-LOCATION object each time a |
| 233 | condition is signalled. For example, if FLOC is a lexical analyser object |
| 234 | which reports its current position in response to FILE-LOCATION, then each |
| 235 | condition will be reported as arising at the lexer's current position at |
| 236 | that time, rather than all being reported at the same position. |
| 237 | |
| 238 | If the new enclosing condition is not handled, the handler established by |
| 239 | this macro will decline to handle the original condition. Typically, |
| 240 | however, the new condition will be handled by COUNT-AND-REPORT-ERRORS." |
| 241 | `(with-default-error-location* ,floc (lambda () ,@body))) |
| 242 | |
| 243 | ;;;----- That's all, folks -------------------------------------------------- |