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

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

diff --git a/src/parser/floc-proto.lisp b/src/parser/floc-proto.lisp
index 484fce05c044e69e8aa1c8cd6c6a71b228701cc0..c681b249288d45eb9f2bc07d14018df10adf5c40 100644 (file)
--- 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)