mdw@git.distorted.org.uk Git - 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 ;;; 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)
 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 'noted)
 149 (defun noted (&optional condition)
 150   "Invoke the `noted' restart, possibly associated with the given CONDITION."
 151   (invoke-associated-restart 'noted condition))
 152
 153 (export 'simple-information-with-location)
 154 (define-condition simple-information-with-location
 155     (information-with-location simple-information)
 156   ())
 157
 158 ;;;--------------------------------------------------------------------------
 159 ;;; Reporting errors.
 160
 161 (export 'enclosing-condition-with-location-type)
 162 (defgeneric enclosing-condition-with-location-type (condition)
 163   (:documentation
 164    "Return a class suitable for attaching location information to CONDITION.
 165
 166     Specifically, return the name of a subclass of `enclosing-condition-
 167     with-location' suitable to enclose CONDITION.")
 168   (:method ((condition error)) 'enclosing-error-with-location)
 169   (:method ((condition warning)) 'enclosing-warning-with-location)
 170   (:method ((condition information)) 'enclosing-information-with-location)
 171   (:method ((condition condition)) 'enclosing-condition-with-location))
 172
 173 (export 'make-condition-with-location)
 174 (defun make-condition-with-location (default-type floc datum &rest arguments)
 175   "Construct a `condition-with-location' given a condition designator.
 176
 177    The returned condition will always be a `condition-with-location'.  The
 178    process consists of two stages.  In the first stage, a condition is
 179    constructed from the condition designator DATUM and ARGUMENTS with default
 180    type DEFAULT-TYPE (a symbol).  The precise behaviour depends on DATUM:
 181
 182      * If DATUM is a condition, then it is used as-is; ARGUMENTS should be an
 183        empty list.
 184
 185      * If DATUM is a symbol, then it must name a condition type.  An instance
 186        of this class is constructed using ARGUMENTS as initargs, i.e., as
 187        if (apply #'make-condition ARGUMENTS); if the type is a subtype of
 188        `condition-with-location' then FLOC is attached as the location.
 189
 190      * If DATUM is a format control (i.e., a string or function), then the
 191        condition is constructed as if, instead, DEFAULT-TYPE had been
 192        supplied as DATUM, and the list (:format-control DATUM
 193        :format-arguments ARGUMENTS) supplied as ARGUMENTS.
 194
 195    In the second stage, the condition constructed by the first stage is
 196    converted into a `condition-with-location'.  If the condition already has
 197    type `condition-with-location' then it is returned as is.  Otherwise it is
 198    wrapped in an appropriate subtype of `enclosing-condition-with-location':
 199    if the condition was a subtype of ERROR or WARNING then the resulting
 200    condition will also be subtype of ERROR or WARNING as appropriate."
 201
 202   (labels ((check-no-args ()
 203              (unless (null arguments)
 204                (error "Argument list provided with specific condition")))
 205            (wrap (condition)
 206              (make-condition
 207               (enclosing-condition-with-location-type condition)
 208               :condition condition
 209               :location (file-location floc)))
 210            (make (type &rest initargs)
 211              (if (subtypep type 'condition-with-location)
 212                  (apply #'make-condition type
 213                         :location (file-location floc)
 214                         initargs)
 215                  (wrap (apply #'make-condition type initargs)))))
 216     (typecase datum
 217       (condition-with-location (check-no-args) datum)
 218       (condition (check-no-args) (wrap datum))
 219       (symbol (apply #'make datum arguments))
 220       ((or string function) (make default-type
 221                                   :format-control datum
 222                                   :format-arguments arguments))
 223       (t (error "Unexpected condition designator datum ~S" datum)))))
 224
 225 (export 'error-with-location)
 226 (defun error-with-location (floc datum &rest arguments)
 227   "Report an error with attached location information."
 228   (error (apply #'make-condition-with-location
 229                 'simple-error-with-location
 230                 floc datum arguments)))
 231
 232 (export 'warn-with-location)
 233 (defun warn-with-location (floc datum &rest arguments)
 234   "Report a warning with attached location information."
 235   (warn (apply #'make-condition-with-location
 236                'simple-warning-with-location
 237                floc datum arguments)))
 238
 239 (export 'info-with-location)
 240 (defun info-with-location (floc datum &rest arguments)
 241   "Report some information with attached location information."
 242   (info (apply #'make-condition-with-location
 243                'simple-information-with-location
 244                floc datum arguments)))
 245
 246 (defun my-cerror (continue-string datum &rest arguments)
 247   "Like standard `cerror', but robust against sneaky changes of conditions.
 248
 249    It seems that `cerror' (well, at least the version in SBCL) is careful
 250    to limit its restart to the specific condition it signalled.  But that's
 251    annoying, because `with-default-error-location' substitutes different
 252    conditions carrying the error-location information."
 253   (restart-case (apply #'error datum arguments)
 254     (continue ()
 255       :report (lambda (stream)
 256                 (apply #'format stream continue-string datum arguments))
 257       nil)))
 258
 259 (export 'cerror-with-location)
 260 (defun cerror-with-location (floc continue-string datum &rest arguments)
 261   "Report a continuable error with attached location information."
 262   (my-cerror continue-string
 263              (apply #'make-condition-with-location
 264                     'simple-error-with-location
 265                     floc datum arguments)))
 266
 267 (export 'cerror*)
 268 (defun cerror* (datum &rest arguments)
 269   (apply #'my-cerror "Continue" datum arguments))
 270
 271 (export 'cerror*-with-location)
 272 (defun cerror*-with-location (floc datum &rest arguments)
 273   (apply #'cerror-with-location floc "Continue" datum arguments))
 274
 275 ;;;--------------------------------------------------------------------------
 276 ;;; Stamping errors with location information.
 277
 278 (let ((control-condition (make-instance 'condition)))
 279   (defun with-default-error-location* (floc thunk)
 280     "Invoke THUNK in a dynamic environment which attaches FLOC to errors (and
 281      other conditions) which do not have file location information attached
 282      to them already.
 283
 284      See the `with-default-error-location' macro for more details."
 285
 286     (if floc
 287         (handler-bind
 288             ((condition-with-location
 289               (lambda (condition)
 290                 (declare (ignore condition))
 291                 :decline))
 292              (condition
 293               (lambda (condition)
 294
 295                 ;; The original condition may have restarts associated with
 296                 ;; it.  Find them and associate them with our new condition
 297                 ;; when we signal that.  For added fun, there isn't a
 298                 ;; function to find just the associated restarts, or to find
 299                 ;; out whether a restart is associated, so do this by making
 300                 ;; up a control condition which has never been associated
 301                 ;; with a restart.
 302                 (let ((enclosing (make-condition-with-location nil floc
 303                                                                condition)))
 304                   (with-condition-restarts enclosing
 305                       (set-difference (compute-restarts condition)
 306                                       (compute-restarts control-condition))
 307                     (signal enclosing))))))
 308           (funcall thunk))
 309         (funcall thunk))))
 310
 311 (export 'with-default-error-location)
 312 (defmacro with-default-error-location ((floc) &body body)
 313   "Evaluate BODY, as an implicit progn, in a dynamic environment which
 314    attaches FLOC to errors (and other conditions) which do not have file
 315    location information attached to them already.
 316
 317    If a condition other than a `condition-with-location' is signalled during
 318    the evaluation of the BODY, then an instance of an appropriate subcalass
 319    of `enclosing-condition-with-location' is constructed, enclosing the
 320    original condition, and signalled.  In particular, if the original
 321    condition was a subtype of ERROR or WARNING, then the new condition will
 322    also be a subtype of ERROR or WARNING as appropriate.
 323
 324    The FLOC argument is coerced to a `file-location' object each time a
 325    condition is signalled.  For example, if FLOC is a lexical analyser object
 326    which reports its current position in response to `file-location', then
 327    each condition will be reported as arising at the lexer's current position
 328    at that time, rather than all being reported at the same position.
 329
 330    If the new enclosing condition is not handled, the handler established by
 331    this macro will decline to handle the original condition.  Typically,
 332    however, the new condition will be handled by `count-and-report-errors'.
 333
 334    As a special case, if FLOC is nil, then no special action is taken, and
 335    BODY is simply evaluated, as an implicit progn."
 336
 337   `(with-default-error-location* ,floc (lambda () ,@body)))
 338
 339 ;;;--------------------------------------------------------------------------
 340 ;;; Custom errors for parsers.
 341
 342 ;; Resolve dependency cycle.
 343 (export '(parser-error-expected parser-error-found))
 344 (defgeneric parser-error-expected (condition))
 345 (defgeneric parser-error-found (condition))
 346
 347 (export 'report-parser-error)
 348 (defun report-parser-error (error stream show-expected show-found)
 349   (format stream "~:[Unexpected~;~
 350                      Expected ~:*~{~#[~;~A~;~A or ~A~:;~
 351                                       ~@{~A, ~#[~;or ~A~]~}~]~} but found~] ~
 352                   ~A"
 353           (mapcar show-expected (parser-error-expected error))
 354           (funcall show-found (parser-error-found error))))
 355
 356 (export 'parser-error)
 357 (define-condition parser-error (error)
 358   ((expected :initarg :expected :reader parser-error-expected :type list)
 359    (found :initarg :found :reader parser-error-found :type t))
 360   (:documentation "Standard error from a parser.
 361
 362    Supports the usual kinds of parser failure, where the parser was expecting
 363    some kinds of things but found something else.")
 364   (:report (lambda (error stream)
 365              (report-parser-error error stream
 366                                   #'prin1-to-string #'prin1-to-string))))
 367
 368 (export '(base-lexer-error simple-lexer-error))
 369 (define-condition base-lexer-error (error-with-location) ())
 370 (define-condition simple-lexer-error
 371     (base-lexer-error simple-error-with-location)
 372   ())
 373
 374 (export '(base-syntax-error simple-syntax-error))
 375 (define-condition base-syntax-error (error-with-location) ())
 376 (define-condition simple-syntax-error
 377     (base-syntax-error simple-error-with-location)
 378   ())
 379
 380 ;;;--------------------------------------------------------------------------
 381 ;;; Front-end error reporting.
 382
 383 (export 'classify-condition)
 384 (defgeneric classify-condition (condition)
 385   (:method ((condition error)) "error")
 386   (:method ((condition base-lexer-error)) "lexical error")
 387   (:method ((condition base-syntax-error)) "syntax error")
 388   (:method ((condition warning)) "warning")
 389   (:method ((condition information)) "note"))
 390
 391 (defun count-and-report-errors* (thunk)
 392   "Invoke THUNK in a dynamic environment which traps and reports errors.
 393
 394    See the `count-and-report-errors' macro for more details."
 395
 396   (let ((errors 0)
 397         (warnings 0))
 398     (restart-case
 399         (let ((our-continue-restart (find-restart 'continue)))
 400           (flet ((report (condition &optional indicator)
 401                    (let ((*print-pretty* nil))
 402                      (format *error-output*
 403                              "~&~A: ~@[~A ~]~A: ~A~%"
 404                              (file-location condition)
 405                              indicator (classify-condition condition)
 406                              condition))))
 407             (handler-bind
 408                 ((error (lambda (error)
 409                           (let ((fatal (eq (find-restart 'continue error)
 410                                            our-continue-restart)))
 411                             (report error (and fatal "fatal"))
 412                             (incf errors)
 413                             (if fatal
 414                                 (return-from count-and-report-errors*
 415                                   (values nil errors warnings))
 416                                 (continue error)))))
 417                  (warning (lambda (warning)
 418                             (report warning)
 419                             (incf warnings)
 420                             (muffle-warning warning)))
 421                  (information (lambda (info)
 422                                 (report info)
 423                                 (noted info))))
 424               (values (funcall thunk)
 425                       errors
 426                       warnings))))
 427       (continue ()
 428         :report (lambda (stream) (write-string "Exit to top-level" stream))
 429         (values nil errors warnings)))))
 430
 431 (export 'count-and-report-errors)
 432 (defmacro count-and-report-errors (() &body body)
 433   "Evaluate BODY in a dynamic environment which traps and reports errors.
 434
 435    The BODY is evaluated.  If an error or warning is signalled, it is
 436    reported (using its report function), and counted.  Warnings are otherwise
 437    muffled; continuable errors (i.e., when a `continue' restart is defined)
 438    are continued; non-continuable errors cause an immediate exit from the
 439    BODY.
 440
 441    The final value consists of three values: the primary value of the BODY
 442    (or nil if a non-continuable error occurred), the number of errors
 443    reported, and the number of warnings reported."
 444   `(count-and-report-errors* (lambda () ,@body)))
 445
 446 ;;;----- That's all, folks --------------------------------------------------