chiark - git - mdw - sod/blob - pre-reorg/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 :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 --------------------------------------------------