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 'information)
  87 (define-condition information (condition)
  88   ())
  89
  90 (export 'error-with-location)
  91 (define-condition error-with-location (condition-with-location error)
  92   ())
  93
  94 (export 'warning-with-location)
  95 (define-condition warning-with-location (condition-with-location warning)
  96   ())
  97
  98 (export 'information-with-location)
  99 (define-condition information-with-location
 100     (condition-with-location information)
 101   ())
 102
 103 (export 'enclosing-error-with-location)
 104 (define-condition enclosing-error-with-location
 105     (enclosing-condition-with-location error)
 106   ())
 107
 108 (export 'enclosing-warning-with-location)
 109 (define-condition enclosing-warning-with-location
 110     (enclosing-condition-with-location warning)
 111   ())
 112
 113 (export 'enclosing-information-with-location)
 114 (define-condition enclosing-information-with-location
 115     (enclosing-condition-with-location information)
 116   ())
 117
 118 (export 'simple-condition-with-location)
 119 (define-condition simple-condition-with-location
 120     (condition-with-location simple-condition)
 121   ())
 122
 123 (export 'simple-error-with-location)
 124 (define-condition simple-error-with-location
 125     (error-with-location simple-error)
 126   ())
 127
 128 (export 'simple-warning-with-location)
 129 (define-condition simple-warning-with-location
 130     (warning-with-location simple-warning)
 131   ())
 132
 133 (export 'simple-information)
 134 (define-condition simple-information (simple-condition information)
 135   ())
 136
 137 (export '(info noted))
 138 (defun info (datum &rest arguments)
 139   "Report some useful diagnostic information.
 140
 141    Establish a simple restart named `noted', and signal the condition of type
 142    `information' designated by DATUM and ARGUMENTS.  Return non-nil if the
 143    restart was invoked, otherwise nil."
 144   (restart-case
 145       (signal (designated-condition 'simple-information datum arguments))
 146     (noted () :report "Noted." t)))
 147
 148 (export 'simple-information-with-location)
 149 (define-condition simple-information-with-location
 150     (information-with-location simple-information)
 151   ())
 152
 153 ;;;--------------------------------------------------------------------------
 154 ;;; Reporting errors.
 155
 156 (export 'enclosing-condition-with-location-type)
 157 (defgeneric enclosing-condition-with-location-type (condition)
 158   (:documentation
 159    "Return a class suitable for attaching location information to CONDITION.
 160
 161     Specifically, return the name of a subclass of `enclosing-condition-
 162     with-location' suitable to enclose CONDITION.")
 163   (:method ((condition error)) 'enclosing-error-with-location)
 164   (:method ((condition warning)) 'enclosing-warning-with-location)
 165   (:method ((condition information)) 'enclosing-information-with-location)
 166   (:method ((condition condition)) 'enclosing-condition-with-location))
 167
 168 (export 'make-condition-with-location)
 169 (defun make-condition-with-location (default-type floc datum &rest arguments)
 170   "Construct a `condition-with-location' given a condition designator.
 171
 172    The returned condition will always be a `condition-with-location'.  The
 173    process consists of two stages.  In the first stage, a condition is
 174    constructed from the condition designator DATUM and ARGUMENTS with default
 175    type DEFAULT-TYPE (a symbol).  The precise behaviour depends on DATUM:
 176
 177      * If DATUM is a condition, then it is used as-is; ARGUMENTS should be an
 178        empty list.
 179
 180      * If DATUM is a symbol, then it must name a condition type.  An instance
 181        of this class is constructed using ARGUMENTS as initargs, i.e., as
 182        if (apply #'make-condition ARGUMENTS); if the type is a subtype of
 183        `condition-with-location' then FLOC is attached as the location.
 184
 185      * If DATUM is a format control (i.e., a string or function), then the
 186        condition is constructed as if, instead, DEFAULT-TYPE had been
 187        supplied as DATUM, and the list (:format-control DATUM
 188        :format-arguments ARGUMENTS) supplied as ARGUMENTS.
 189
 190    In the second stage, the condition constructed by the first stage is
 191    converted into a `condition-with-location'.  If the condition already has
 192    type `condition-with-location' then it is returned as is.  Otherwise it is
 193    wrapped in an appropriate subtype of `enclosing-condition-with-location':
 194    if the condition was a subtype of ERROR or WARNING then the resulting
 195    condition will also be subtype of ERROR or WARNING as appropriate."
 196
 197   (labels ((check-no-args ()
 198              (unless (null arguments)
 199                (error "Argument list provided with specific condition")))
 200            (wrap (condition)
 201              (make-condition
 202               (enclosing-condition-with-location-type condition)
 203               :condition condition
 204               :location (file-location floc)))
 205            (make (type &rest initargs)
 206              (if (subtypep type 'condition-with-location)
 207                  (apply #'make-condition type
 208                         :location (file-location floc)
 209                         initargs)
 210                  (wrap (apply #'make-condition type initargs)))))
 211     (typecase datum
 212       (condition-with-location (check-no-args) datum)
 213       (condition (check-no-args) (wrap datum))
 214       (symbol (apply #'make datum arguments))
 215       ((or string function) (make default-type
 216                                   :format-control datum
 217                                   :format-arguments arguments))
 218       (t (error "Unexpected condition designator datum ~S" datum)))))
 219
 220 (export 'error-with-location)
 221 (defun error-with-location (floc datum &rest arguments)
 222   "Report an error with attached location information."
 223   (error (apply #'make-condition-with-location
 224                 'simple-error-with-location
 225                 floc datum arguments)))
 226
 227 (export 'warn-with-location)
 228 (defun warn-with-location (floc datum &rest arguments)
 229   "Report a warning with attached location information."
 230   (warn (apply #'make-condition-with-location
 231                'simple-warning-with-location
 232                floc datum arguments)))
 233
 234 (export 'info-with-location)
 235 (defun info-with-location (floc datum &rest arguments)
 236   "Report some information with attached location information."
 237   (info (apply #'make-condition-with-location
 238                'simple-information-with-location
 239                floc datum arguments)))
 240
 241 (defun my-cerror (continue-string datum &rest arguments)
 242   "Like standard `cerror', but robust against sneaky changes of conditions.
 243
 244    It seems that `cerror' (well, at least the version in SBCL) is careful
 245    to limit its restart to the specific condition it signalled.  But that's
 246    annoying, because `with-default-error-location' substitutes different
 247    conditions carrying the error-location information."
 248   (restart-case (apply #'error datum arguments)
 249     (continue ()
 250       :report (lambda (stream)
 251                 (apply #'format stream continue-string datum arguments))
 252       nil)))
 253
 254 (export 'cerror-with-location)
 255 (defun cerror-with-location (floc continue-string datum &rest arguments)
 256   "Report a continuable error with attached location information."
 257   (my-cerror continue-string
 258              (apply #'make-condition-with-location
 259                     'simple-error-with-location
 260                     floc datum arguments)))
 261
 262 (export 'cerror*)
 263 (defun cerror* (datum &rest arguments)
 264   (apply #'my-cerror "Continue" datum arguments))
 265
 266 (export 'cerror*-with-location)
 267 (defun cerror*-with-location (floc datum &rest arguments)
 268   (apply #'cerror-with-location floc "Continue" datum arguments))
 269
 270 ;;;--------------------------------------------------------------------------
 271 ;;; Stamping errors with location information.
 272
 273 (defun with-default-error-location* (floc thunk)
 274   "Invoke THUNK in a dynamic environment which attaches FLOC to errors (and
 275    other conditions) which do not have file location information attached to
 276    them already.
 277
 278    See the `with-default-error-location' macro for more details."
 279
 280   (if floc
 281       (handler-bind
 282           ((condition-with-location
 283             (lambda (condition)
 284               (declare (ignore condition))
 285               :decline))
 286            (condition
 287             (lambda (condition)
 288               (signal (make-condition-with-location nil floc condition)))))
 289         (funcall thunk))
 290       (funcall thunk)))
 291
 292 (export 'with-default-error-location)
 293 (defmacro with-default-error-location ((floc) &body body)
 294   "Evaluate BODY, as an implicit progn, in a dynamic environment which
 295    attaches FLOC to errors (and other conditions) which do not have file
 296    location information attached to them already.
 297
 298    If a condition other than a `condition-with-location' is signalled during
 299    the evaluation of the BODY, then an instance of an appropriate subcalass
 300    of `enclosing-condition-with-location' is constructed, enclosing the
 301    original condition, and signalled.  In particular, if the original
 302    condition was a subtype of ERROR or WARNING, then the new condition will
 303    also be a subtype of ERROR or WARNING as appropriate.
 304
 305    The FLOC argument is coerced to a `file-location' object each time a
 306    condition is signalled.  For example, if FLOC is a lexical analyser object
 307    which reports its current position in response to `file-location', then
 308    each condition will be reported as arising at the lexer's current position
 309    at that time, rather than all being reported at the same position.
 310
 311    If the new enclosing condition is not handled, the handler established by
 312    this macro will decline to handle the original condition.  Typically,
 313    however, the new condition will be handled by `count-and-report-errors'.
 314
 315    As a special case, if FLOC is nil, then no special action is taken, and
 316    BODY is simply evaluated, as an implicit progn."
 317
 318   `(with-default-error-location* ,floc (lambda () ,@body)))
 319
 320 ;;;--------------------------------------------------------------------------
 321 ;;; Front-end error reporting.
 322
 323 (defun count-and-report-errors* (thunk)
 324   "Invoke THUNK in a dynamic environment which traps and reports errors.
 325
 326    See the `count-and-report-errors' macro for more details."
 327
 328   (let ((errors 0)
 329         (warnings 0))
 330     (restart-case
 331         (let ((our-continue-restart (find-restart 'continue)))
 332           (handler-bind
 333               ((error (lambda (error)
 334                         (let ((fatal (eq (find-restart 'continue error)
 335                                          our-continue-restart)))
 336                           (format *error-output*
 337                                   "~&~A: ~:[~;Fatal error: ~]~A~%"
 338                                   (file-location error)
 339                                   fatal
 340                                   error)
 341                           (incf errors)
 342                           (if fatal
 343                               (return-from count-and-report-errors*
 344                                 (values nil errors warnings))
 345                               (invoke-restart 'continue)))))
 346                (warning (lambda (warning)
 347                           (format *error-output* "~&~A: Warning: ~A~%"
 348                                   (file-location warning)
 349                                   warning)
 350                           (incf warnings)
 351                           (invoke-restart 'muffle-warning)))
 352                (information (lambda (info)
 353                               (format *error-output* "~&~A: Info: ~A~%"
 354                                       (file-location info)
 355                                       info)
 356                           (invoke-restart 'noted))))
 357             (values (funcall thunk)
 358                     errors
 359                     warnings)))
 360       (continue ()
 361         :report (lambda (stream) (write-string "Exit to top-level" stream))
 362         (values nil errors warnings)))))
 363
 364 (export 'count-and-report-errors)
 365 (defmacro count-and-report-errors (() &body body)
 366   "Evaluate BODY in a dynamic environment which traps and reports errors.
 367
 368    The BODY is evaluated.  If an error or warning is signalled, it is
 369    reported (using its report function), and counted.  Warnings are otherwise
 370    muffled; continuable errors (i.e., when a `continue' restart is defined)
 371    are continued; non-continuable errors cause an immediate exit from the
 372    BODY.
 373
 374    The final value consists of three values: the primary value of the BODY
 375    (or nil if a non-continuable error occurred), the number of errors
 376    reported, and the number of warnings reported."
 377   `(count-and-report-errors* (lambda () ,@body)))
 378
 379 ;;;----- That's all, folks --------------------------------------------------