src/parser/floc-proto.lisp: Add `enclosing-condition-with-location-type'.

Split out the piece of `make-condition-with-location' which figures out
the appropriate subclass of `condition-with-location' to use to wrap a
given condition so that it can be extended more easily.

diff --git a/doc/SYMBOLS b/doc/SYMBOLS
index 36a700b39c42757e613f02be1916be876f4ac3d0..e903d918169d8d0750cc1a25b4de198c4d8e17c7 100644 (file)
--- a/doc/SYMBOLS
+++ b/doc/SYMBOLS
@@ -1577,6 +1577,7 @@ floc-proto.lisp
   enclosed-condition                            generic
   enclosing-condition                           class
   enclosing-condition-with-location             class
+  enclosing-condition-with-location-type        generic
   enclosing-error-with-location                 class
   enclosing-warning-with-location               class
   error-with-location                           function class
@@ -1860,6 +1861,10 @@ charbuf-scanner-map
   charbuf-scanner t
 enclosed-condition
   enclosing-condition
+enclosing-condition-with-location-type
+  cl:condition
+  cl:error
+  cl:warning
 expand-parser-form
   t (eql cl:and) t
   t (eql cl:list) t

diff --git a/doc/parsing.tex b/doc/parsing.tex
index ac878b41825c6d79695b71dca761b6866dfede1f..c3cc0032a8c66179a539588f7452e9b5e1ed5ec8 100644 (file)
--- a/doc/parsing.tex
+++ b/doc/parsing.tex
@@ -116,6 +116,10 @@ consumed any input items.
          \&key :format-control :format-arguments :location}}
 \end{describe*}
 
+\begin{describe}{gf}
+    {enclosing-condition-with-location-type @<condition> @> @<symbol>}
+\end{describe}
+
 \begin{describe}{fun}
     {make-condition-with-location @<default-type> @<floc>
                                   @<datum> \&rest @<arguments>

diff --git a/src/parser/floc-proto.lisp b/src/parser/floc-proto.lisp
index c681b249288d45eb9f2bc07d14018df10adf5c40..e3dca325d8b28565fc0a07676a2541ecd61b66fe 100644 (file)
--- a/src/parser/floc-proto.lisp
+++ b/src/parser/floc-proto.lisp
@@ -119,6 +119,17 @@ (define-condition simple-warning-with-location
 ;;;--------------------------------------------------------------------------
 ;;; Reporting errors.
 
+(export 'enclosing-condition-with-location-type)
+(defgeneric enclosing-condition-with-location-type (condition)
+  (:documentation
+   "Return a class suitable for attaching location information to CONDITION.
+
+    Specifically, return the name of a subclass of `enclosing-condition-
+    with-location' suitable to enclose CONDITION.")
+  (:method ((condition error)) 'enclosing-error-with-location)
+  (:method ((condition warning)) 'enclosing-warning-with-location)
+  (:method ((condition condition)) 'enclosing-condition-with-location))
+
 (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.
@@ -153,10 +164,7 @@ (defun make-condition-with-location (default-type floc datum &rest arguments)
               (error "Argument list provided with specific condition")))
           (wrap (condition)
             (make-condition
-             (etypecase condition
-               (error 'enclosing-error-with-location)
-               (warning 'enclosing-warning-with-location)
-               (condition 'enclosing-condition-with-location))
+             (enclosing-condition-with-location-type condition)
              :condition condition
              :location (file-location floc)))
           (make (type &rest initargs)