plain T and OTHERWISE not allowed in CASE normal-clauses

  lp#959687

diff --git a/NEWS b/NEWS
index 8c375a1..85e34f6 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -2,6 +2,8 @@
 changes relative to sbcl-1.0.55:
   * bug fix: SB-SIMPLE-STREAMS signals an error for bogus :CLASS arguments in
     OPEN. (lp#969352, thanks to Kambiz Darabi)
+  * bug fix: CASE normal-clauses do not allow T and OTHERWISE as keys.
+    (lp#959687)
   * documentation:
     ** improved docstrings: REPLACE (lp#965592)
 

diff --git a/src/code/macros.lisp b/src/code/macros.lisp
index 7525fbf..935fe5b 100644 (file)
--- a/src/code/macros.lisp
+++ b/src/code/macros.lisp
@@ -261,6 +261,17 @@ invoked. In that case it will store into PLACE and start over."
                          ,@forms)
                        clauses))
                 (t
+                 (when (and (eq name 'case)
+                            (cdr cases)
+                            (memq keyoid '(t otherwise)))
+                   (error 'simple-reference-error
+                          :format-control
+                          "~@<~IBad ~S clause:~:@_  ~S~:@_~S allowed as the key ~
+                           designator only in the final otherwise-clause, not in a ~
+                           normal-clause. Use (~S) instead, or move the clause the ~
+                           correct position.~:@>"
+                          :format-arguments (list 'case case keyoid keyoid)
+                          :references `((:ansi-cl :macro case))))
                  (push keyoid keys)
                  (check-clause (list keyoid))
                  (push `((,test ,keyform-value ',keyoid)

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index e081b4e..67ded22 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4179,3 +4179,23 @@
                   (declare (optimize speed)
                            (type (and fixnum a) x))
                   x)))
+
+(with-test (:name :bug-959687)
+  (multiple-value-bind (fun warn fail)
+      (compile nil `(lambda (x)
+                      (case x
+                        (t
+                         :its-a-t)
+                        (otherwise
+                         :somethign-else))))
+    (assert (and warn fail))
+    (assert (not (ignore-errors (funcall fun t)))))
+  (multiple-value-bind (fun warn fail)
+      (compile nil `(lambda (x)
+                      (case x
+                        (otherwise
+                         :its-an-otherwise)
+                        (t
+                         :somethign-else))))
+    (assert (and warn fail))
+    (assert (not (ignore-errors (funcall fun t))))))