chiark - git - mdw - sod/blob - src/parser/floc-proto.lisp

   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 &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 ((check-no-args ()
 152              (unless (null arguments)
 153                (error "Argument list provided with specific condition")))
 154            (wrap (condition)
 155              (make-condition
 156               (etypecase condition
 157                 (error 'enclosing-error-with-location)
 158                 (warning 'enclosing-warning-with-location)
 159                 (condition 'enclosing-condition-with-location))
 160               :condition condition
 161               :location (file-location floc)))
 162            (make (type &rest initargs)
 163              (if (subtypep type 'condition-with-location)
 164                  (apply #'make-condition type
 165                         :location (file-location floc)
 166                         initargs)
 167                  (wrap (apply #'make-condition type initargs)))))
 168     (typecase datum
 169       (condition-with-location (check-no-args) datum)
 170       (condition (check-no-args) (wrap datum))
 171       (symbol (apply #'make datum arguments))
 172       ((or string function) (make default-type
 173                                   :format-control datum
 174                                   :format-arguments arguments))
 175       (t (error "Unexpected condition designator datum ~S" datum)))))
 176
 177 (export 'error-with-location)
 178 (defun error-with-location (floc datum &rest arguments)
 179   "Report an error with attached location information."
 180   (error (apply #'make-condition-with-location
 181                 'simple-error-with-location
 182                 floc datum arguments)))
 183
 184 (export 'warn-with-location)
 185 (defun warn-with-location (floc datum &rest arguments)
 186   "Report a warning with attached location information."
 187   (warn (apply #'make-condition-with-location
 188                'simple-warning-with-location
 189                floc datum arguments)))
 190
 191 (defun my-cerror (continue-string datum &rest arguments)
 192   "Like standard `cerror', but robust against sneaky changes of conditions.
 193
 194    It seems that `cerror' (well, at least the version in SBCL) is careful
 195    to limit its restart to the specific condition it signalled.  But that's
 196    annoying, because `with-default-error-location' substitutes different
 197    conditions carrying the error-location information."
 198   (restart-case (apply #'error datum arguments)
 199     (continue ()
 200       :report (lambda (stream)
 201                 (apply #'format stream continue-string datum arguments))
 202       nil)))
 203
 204 (export 'cerror-with-location)
 205 (defun cerror-with-location (floc continue-string datum &rest arguments)
 206   "Report a continuable error with attached location information."
 207   (my-cerror continue-string
 208              (apply #'make-condition-with-location
 209                     'simple-error-with-location
 210                     floc datum arguments)))
 211
 212 (export 'cerror*)
 213 (defun cerror* (datum &rest arguments)
 214   (apply #'my-cerror "Continue" datum arguments))
 215
 216 (export 'cerror*-with-location)
 217 (defun cerror*-with-location (floc datum &rest arguments)
 218   (apply #'cerror-with-location floc "Continue" datum arguments))
 219
 220 ;;;--------------------------------------------------------------------------
 221 ;;; Stamping errors with location information.
 222
 223 (defun with-default-error-location* (floc thunk)
 224   "Invoke THUNK 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    See the `with-default-error-location' macro for more details."
 229
 230   (if floc
 231       (handler-bind
 232           ((condition-with-location
 233             (lambda (condition)
 234               (declare (ignore condition))
 235               :decline))
 236            (condition
 237             (lambda (condition)
 238               (signal (make-condition-with-location nil floc condition)))))
 239         (funcall thunk))
 240       (funcall thunk)))
 241
 242 (export 'with-default-error-location)
 243 (defmacro with-default-error-location ((floc) &body body)
 244   "Evaluate BODY, as an implicit progn, in a dynamic environment which
 245    attaches FLOC to errors (and other conditions) which do not have file
 246    location information attached to them already.
 247
 248    If a condition other than a `condition-with-location' is signalled during
 249    the evaluation of the BODY, then an instance of an appropriate subcalass
 250    of `enclosing-condition-with-location' is constructed, enclosing the
 251    original condition, and signalled.  In particular, if the original
 252    condition was a subtype of ERROR or WARNING, then the new condition will
 253    also be a subtype of ERROR or WARNING as appropriate.
 254
 255    The FLOC argument is coerced to a `file-location' object each time a
 256    condition is signalled.  For example, if FLOC is a lexical analyser object
 257    which reports its current position in response to `file-location', then
 258    each condition will be reported as arising at the lexer's current position
 259    at that time, rather than all being reported at the same position.
 260
 261    If the new enclosing condition is not handled, the handler established by
 262    this macro will decline to handle the original condition.  Typically,
 263    however, the new condition will be handled by `count-and-report-errors'.
 264
 265    As a special case, if FLOC is nil, then no special action is taken, and
 266    BODY is simply evaluated, as an implicit progn."
 267
 268   `(with-default-error-location* ,floc (lambda () ,@body)))
 269
 270 ;;;--------------------------------------------------------------------------
 271 ;;; Front-end error reporting.
 272
 273 (defun count-and-report-errors* (thunk)
 274   "Invoke THUNK in a dynamic environment which traps and reports errors.
 275
 276    See the `count-and-report-errors' macro for more details."
 277
 278   (let ((errors 0)
 279         (warnings 0))
 280     (restart-case
 281         (let ((our-continue-restart (find-restart 'continue)))
 282           (handler-bind
 283               ((error (lambda (error)
 284                         (let ((fatal (eq (find-restart 'continue error)
 285                                          our-continue-restart)))
 286                           (format *error-output*
 287                                   "~&~A: ~:[~;Fatal error: ~]~A~%"
 288                                   (file-location error)
 289                                   fatal
 290                                   error)
 291                           (incf errors)
 292                           (if fatal
 293                               (return-from count-and-report-errors*
 294                                 (values nil errors warnings))
 295                               (invoke-restart 'continue)))))
 296                (warning (lambda (warning)
 297                           (format *error-output* "~&~A: Warning: ~A~%"
 298                                   (file-location warning)
 299                                   warning)
 300                           (incf warnings)
 301                           (invoke-restart 'muffle-warning))))
 302             (values (funcall thunk)
 303                     errors
 304                     warnings)))
 305       (continue ()
 306         :report (lambda (stream) (write-string "Exit to top-level" stream))
 307         (values nil errors warnings)))))
 308
 309 (export 'count-and-report-errors)
 310 (defmacro count-and-report-errors (() &body body)
 311   "Evaluate BODY in a dynamic environment which traps and reports errors.
 312
 313    The BODY is evaluated.  If an error or warning is signalled, it is
 314    reported (using its report function), and counted.  Warnings are otherwise
 315    muffled; continuable errors (i.e., when a `continue' restart is defined)
 316    are continued; non-continuable errors cause an immediate exit from the
 317    BODY.
 318
 319    The final value consists of three values: the primary value of the BODY
 320    (or nil if a non-continuable error occurred), the number of errors
 321    reported, and the number of warnings reported."
 322   `(count-and-report-errors* (lambda () ,@body)))
 323
 324 ;;;----- That's all, folks --------------------------------------------------