src/parser/floc-proto.lisp: Restore missing argument.

[sod] / src / parser / floc-proto.lisp

;;; -*-lisp-*-
;;;
;;; Protocol for file locations
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensible 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 &optional 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 datum 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)))

(defun my-cerror (continue-string datum &rest arguments)
  "Like standard `cerror', but robust against sneaky changes of conditions.

   It seems that `cerror' (well, at least the version in SBCL) is careful
   to limit its restart to the specific condition it signalled.  But that's
   annoying, because `with-default-error-location' substitutes different
   conditions carrying the error-location information."
  (restart-case (apply #'error datum arguments)
    (continue ()
      :report (lambda (stream)
		(apply #'format stream continue-string datum arguments))
      nil)))

(export 'cerror-with-location)
(defun cerror-with-location (floc continue-string datum &rest arguments)
  "Report a continuable error with attached location information."
  (my-cerror continue-string
	     (apply #'make-condition-with-location
		    'simple-error-with-location
		    floc datum arguments)))

(export 'cerror*)
(defun cerror* (datum &rest arguments)
  (apply #'my-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 details."

  (let ((errors 0)
	(warnings 0))
    (restart-case
	(let ((our-continue-restart (find-restart 'continue)))
	  (handler-bind
	      ((error (lambda (error)
			(let ((fatal (eq (find-restart 'continue error)
					 our-continue-restart)))
			  (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)))
      (continue ()
	:report (lambda (stream) (write-string "Exit to top-level" stream))
	(values nil 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 --------------------------------------------------