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