chiark - git - mdw - sod/blob - errors.lisp

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