--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Protocol for file locations
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; SOD is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod-parser)
+
+;;;--------------------------------------------------------------------------
+;;; File location objects.
+
+(export '(file-location make-file-location file-location-p
+ file-location-filename file-location-line file-location-column))
+(defstruct (file-location
+ (:constructor make-file-location
+ (%filename line column
+ &aux (filename
+ (etypecase %filename
+ ((or string null) %filename)
+ (pathname (namestring %filename)))))))
+ "A simple structure containing file location information.
+
+ Construct using MAKE-FILE-LOCATION; the main useful function is
+ ERROR-FILE-LOCATION."
+ (filename nil :type (or string null) :read-only t)
+ (line nil :type (or fixnum null) :read-only t)
+ (column nil :type (or fixnum null) :read-only t))
+
+(defgeneric file-location (thing)
+ (:documentation
+ "Convert THING into a FILE-LOCATION, if possible.
+
+ A THING which can be converted into a FILE-LOCATION is termed a
+ `file-location designator'.")
+ (:method ((thing file-location)) thing))
+
+;;;--------------------------------------------------------------------------
+;;; Enclosing conditions.
+
+(export '(enclosing-condition enclosed-condition))
+(define-condition enclosing-condition (condition)
+ ((enclosed-condition :initarg :condition :type condition
+ :reader enclosed-condition))
+ (:documentation
+ "A condition which encloses another condition
+
+ This is useful if one wants to attach additional information to an
+ existing condition. The enclosed condition can be obtained using the
+ ENCLOSED-CONDITION function.")
+ (:report (lambda (condition stream)
+ (princ (enclosed-condition condition) stream))))
+
+;;;--------------------------------------------------------------------------
+;;; Conditions with location information.
+
+(export 'condition-with-location)
+(define-condition condition-with-location (condition)
+ ((location :initarg :location :reader file-location :type file-location))
+ (:documentation
+ "A condition which has some location information attached."))
+
+(export 'enclosing-condition-with-location)
+(define-condition enclosing-condition-with-location
+ (condition-with-location enclosing-condition)
+ ())
+
+(export 'error-with-location)
+(define-condition error-with-location (condition-with-location error)
+ ())
+
+(export 'warning-with-location)
+(define-condition warning-with-location (condition-with-location warning)
+ ())
+
+(export 'enclosing-error-with-location)
+(define-condition enclosing-error-with-location
+ (enclosing-condition-with-location error)
+ ())
+
+(export 'enclosing-warning-with-location)
+(define-condition enclosing-warning-with-location
+ (enclosing-condition-with-location warning)
+ ())
+
+(export 'simple-condition-with-location)
+(define-condition simple-condition-with-location
+ (condition-with-location simple-condition)
+ ())
+
+(export 'simple-error-with-location)
+(define-condition simple-error-with-location
+ (error-with-location simple-error)
+ ())
+
+(export 'simple-warning-with-location)
+(define-condition simple-warning-with-location
+ (warning-with-location simple-warning)
+ ())
+
+;;;--------------------------------------------------------------------------
+;;; Reporting errors.
+
+(export 'make-condition-with-location)
+(defun make-condition-with-location (default-type floc datum &rest arguments)
+ "Construct a CONDITION-WITH-LOCATION given a condition designator.
+
+ The returned condition will always be a CONDITION-WITH-LOCATION. The
+ process consists of two stages. In the first stage, a condition is
+ constructed from the condition designator DATUM and ARGUMENTS with default
+ type DEFAULT-TYPE (a symbol). The precise behaviour depends on DATUM:
+
+ * If DATUM is a condition, then it is used as-is; ARGUMENTS should be an
+ empty list.
+
+ * If DATUM is a symbol, then it must name a condition type. An instance
+ of this class is constructed using ARGUMENTS as initargs, i.e., as
+ if (apply #'make-condition ARGUMENTS); if the type is a subtype of
+ CONDITION-WITH-LOCATION then FLOC is attached as the location.
+
+ * If DATUM is a format control (i.e., a string or function), then the
+ condition is constructed as if, instead, DEFAULT-TYPE had been
+ supplied as DATUM, and the list (:format-control DATUM
+ :format-arguments ARGUMENTS) supplied as ARGUMENTS.
+
+ In the second stage, the condition constructed by the first stage is
+ converted into a CONDITION-WITH-LOCATION. If the condition already has
+ type CONDITION-WITH-LOCATION then it is returned as is. Otherwise it is
+ wrapped in an appropriate subtype of ENCLOSING-CONDITION-WITH-LOCATION:
+ if the condition was a subtype of ERROR or WARNING then the resulting
+ condition will also be subtype of ERROR or WARNING as appropriate."
+
+ (labels ((wrap (condition)
+ (make-condition
+ (etypecase condition
+ (error 'enclosing-error-with-location)
+ (warning 'enclosing-warning-with-location)
+ (condition 'enclosing-condition-with-location))
+ :condition condition
+ :location (file-location floc)))
+ (make (type &rest initargs)
+ (if (subtypep type 'condition-with-location)
+ (apply #'make-condition type
+ :location (file-location floc)
+ initargs)
+ (wrap (apply #'make-condition type initargs)))))
+ (etypecase datum
+ (condition-with-location datum)
+ (condition (wrap datum))
+ (symbol (apply #'make arguments))
+ ((or string function) (make default-type
+ :format-control datum
+ :format-arguments arguments)))))
+
+(export 'error-with-location)
+(defun error-with-location (floc datum &rest arguments)
+ "Report an error with attached location information."
+ (error (apply #'make-condition-with-location
+ 'simple-error-with-location
+ floc datum arguments)))
+
+(export 'warn-with-location)
+(defun warn-with-location (floc datum &rest arguments)
+ "Report a warning with attached location information."
+ (warn (apply #'make-condition-with-location
+ 'simple-warning-with-location
+ floc datum arguments)))
+
+(export 'cerror-with-location)
+(defun cerror-with-location (floc continue-string datum &rest arguments)
+ "Report a continuable error with attached location information."
+ (cerror continue-string
+ (apply #'make-condition-with-location
+ 'simple-error-with-location
+ floc datum arguments)))
+
+(export 'cerror*)
+(defun cerror* (datum &rest arguments)
+ (apply #'cerror "Continue" datum arguments))
+
+(export 'cerror*-with-location)
+(defun cerror*-with-location (floc datum &rest arguments)
+ (apply #'cerror-with-location floc "Continue" datum arguments))
+
+;;;--------------------------------------------------------------------------
+;;; Stamping errors with location information.
+
+(defun with-default-error-location* (floc thunk)
+ "Invoke THUNK in a dynamic environment which attaches FLOC to errors (and
+ other conditions) which do not have file location information attached to
+ them already.
+
+ See the WITH-DEFAULT-ERROR-LOCATION macro for more details."
+
+ (if floc
+ (handler-bind
+ ((condition-with-location
+ (lambda (condition)
+ (declare (ignore condition))
+ :decline))
+ (condition
+ (lambda (condition)
+ (signal (make-condition-with-location nil floc condition)))))
+ (funcall thunk))
+ (funcall thunk)))
+
+(export 'with-default-error-location)
+(defmacro with-default-error-location ((floc) &body body)
+ "Evaluate BODY, as an implicit progn, in a dynamic environment which
+ attaches FLOC to errors (and other conditions) which do not have file
+ location information attached to them already.
+
+ If a condition other than a CONDITION-WITH-LOCATION is signalled during
+ the evaluation of the BODY, then an instance of an appropriate subcalass
+ of ENCLOSING-CONDITION-WITH-LOCATION is constructed, enclosing the
+ original condition, and signalled. In particular, if the original
+ condition was a subtype of ERROR or WARNING, then the new condition will
+ also be a subtype of ERROR or WARNING as appropriate.
+
+ The FLOC argument is coerced to a FILE-LOCATION object each time a
+ condition is signalled. For example, if FLOC is a lexical analyser object
+ which reports its current position in response to FILE-LOCATION, then each
+ condition will be reported as arising at the lexer's current position at
+ that time, rather than all being reported at the same position.
+
+ If the new enclosing condition is not handled, the handler established by
+ this macro will decline to handle the original condition. Typically,
+ however, the new condition will be handled by COUNT-AND-REPORT-ERRORS.
+
+ As a special case, if FLOC is nil, then no special action is taken, and
+ BODY is simply evaluated, as an implicit progn."
+
+ `(with-default-error-location* ,floc (lambda () ,@body)))
+
+;;;--------------------------------------------------------------------------
+;;; Front-end error reporting.
+
+(defun count-and-report-errors* (thunk)
+ "Invoke THUNK in a dynamic environment which traps and reports errors.
+
+ See the COUNT-AND-REPORT-ERRORS macro for more detais."
+
+ (let ((errors 0)
+ (warnings 0))
+ (handler-bind
+ ((error (lambda (error)
+ (let ((fatal (not (find-restart 'continue error))))
+ (format *error-output* "~&~A: ~:[~;Fatal error: ~]~A~%"
+ (file-location error)
+ fatal
+ error)
+ (incf errors)
+ (if fatal
+ (return-from count-and-report-errors*
+ (values nil errors warnings))
+ (invoke-restart 'continue)))))
+ (warning (lambda (warning)
+ (format *error-output* "~&~A: Warning: ~A~%"
+ (file-location warning)
+ warning)
+ (incf warnings)
+ (invoke-restart 'muffle-warning))))
+ (values (funcall thunk)
+ errors
+ warnings))))
+
+(export 'count-and-report-errors)
+(defmacro count-and-report-errors (() &body body)
+ "Evaluate BODY in a dynamic environment which traps and reports errors.
+
+ The BODY is evaluated. If an error or warning is signalled, it is
+ reported (using its report function), and counted. Warnings are otherwise
+ muffled; continuable errors (i.e., when a CONTINUE restart is defined) are
+ continued; non-continuable errors cause an immediate exit from the BODY.
+
+ The final value consists of three values: the primary value of the BODY
+ (or NIL if a non-continuable error occurred), the number of errors
+ reported, and the number of warnings reported."
+ `(count-and-report-errors* (lambda () ,@body)))
+
+;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff