From: Mark Wooding <mdw@distorted.org.uk>
Date: Thu, 26 May 2016 08:26:09 +0000 (+0100)
Subject: src/parser/floc-proto.lisp: Add `enclosing-condition-with-location-type'.
X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/commitdiff_plain/388ab3827ab7c584c30723f5044c2a38cf6fe55d

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 36a700b..e903d91 100644
--- 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 ac878b4..c3cc003 100644
--- 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 c681b24..e3dca32 100644
--- 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)