From: Mark Wooding <mdw@distorted.org.uk>
Date: Thu, 26 May 2016 08:26:09 +0000 (+0100)
Subject: src/parser/floc-proto.lisp (make-condition-with-location): Error checking.
X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/commitdiff_plain/ad1316527a6aa066d0abc0ada46a3616f5cb451f?ds=inline

src/parser/floc-proto.lisp (make-condition-with-location): Error checking.

Check for errors rather than just mentioning them in the docstring.
---

diff --git a/src/parser/floc-proto.lisp b/src/parser/floc-proto.lisp
index 484fce0..c681b24 100644
--- a/src/parser/floc-proto.lisp
+++ b/src/parser/floc-proto.lisp
@@ -148,7 +148,10 @@ (defun make-condition-with-location (default-type floc datum &rest arguments)
    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)
+  (labels ((check-no-args ()
+	     (unless (null arguments)
+	       (error "Argument list provided with specific condition")))
+	   (wrap (condition)
 	     (make-condition
 	      (etypecase condition
 		(error 'enclosing-error-with-location)
@@ -162,13 +165,14 @@ (defun make-condition-with-location (default-type floc datum &rest arguments)
 			:location (file-location floc)
 			initargs)
 		 (wrap (apply #'make-condition type initargs)))))
-    (etypecase datum
-      (condition-with-location datum)
-      (condition (wrap datum))
+    (typecase datum
+      (condition-with-location (check-no-args) datum)
+      (condition (check-no-args) (wrap datum))
       (symbol (apply #'make datum arguments))
       ((or string function) (make default-type
 				  :format-control datum
-				  :format-arguments arguments)))))
+				  :format-arguments arguments))
+      (t (error "Unexpected condition designator datum ~S" datum)))))
 
 (export 'error-with-location)
 (defun error-with-location (floc datum &rest arguments)