Changeset 909

Timestamp:

Feb 16, 2005, 11:05:59 AM (20 years ago)

Author:

bryan

Message:

typecase was always pushing the t clause (if present) to the end of
the clauses. i suspect that most cases when it appears before the
end, the user intended for it to be equivalent to a final OTHERWISE
clause. hopefully the warning messages about later clauses being
shadowed will be sufficient to alert them. as an added benefit it
dead-code strips any cases following a t-clause.

finally it now correctly raises an error if OTHERWISE (if present)
is not the final clause.

File:

• trunk/ccl/lib/macros.lisp (modified) (1 diff)

trunk/ccl/lib/macros.lisp

@@ -786 +786 @@
   (let* ((construct (if e-c-p (if (eq e-c-p 'etypecase) e-c-p 'ctypecase) 'typecase))
          (types ())
-         (t-clause ())
-         (body ()))
+         (body ())
+         otherwise-seen-p)
     (flet ((bad-clause (c) 
              (error "Invalid clause ~S in ~S form." c construct)))
       (dolist (clause clauses)
         (if (atom clause)
-          (bad-clause clause)
-          (destructuring-bind (typespec &body consequents) clause
-            (when (eq construct 'typecase)
-              (if (eq typespec 'otherwise)
-                (setq typespec t))
-              (if (eq typespec t)
-                (if t-clause
-                  (bad-clause clause)   ; seen one already
-                  (setq t-clause `( t nil ,@consequents)))))
-            (unless (and (eq construct 'typecase)
-                         (eq typespec t))
-              (when
-                  (dolist (already types t)
-                    (when (subtypep typespec already)
-                      (warn "Clause ~S ignored in ~S form - shadowed by ~S ." clause construct (assq already clauses))
-                      (return)))
-                (push typespec types)
-                (unless (eq typespec t)
-                  (setq typespec `(typep ,key-var ',typespec)))
-                (push `(,typespec nil ,@consequents) body))))))
+            (bad-clause clause))
+        (if otherwise-seen-p
+            (error "OTHERWISE must be final clause in ~S form." construct))
+        (destructuring-bind (typespec &body consequents) clause
+          (when (eq construct 'typecase)
+            (if (eq typespec 'otherwise)
+                (progn (setq typespec t)
+                       (setq otherwise-seen-p t))))
+          (unless
+              (dolist (already types nil)
+                (when (subtypep typespec already)
+                  (warn "Clause ~S ignored in ~S form - shadowed by ~S ." clause construct (assq already clauses))
+                  (return t)))
+            (push typespec types)
+            (setq typespec `(typep ,key-var ',typespec))
+            (push `(,typespec nil ,@consequents) body))))
       (when e-c-p
         (setq types `(or ,@(nreverse types)))
         (if (eq construct 'etypecase)
-          (push `(t (values (%err-disp #.$XWRONGTYPE ,key-var ',types))) body)
-          (push `(t (setf ,keyform (ensure-value-of-type ,key-var ',types ',keyform))
-                  (go ,e-c-p)) body))))
-    (when t-clause
-      (push t-clause body))
+            (push `(t (values (%err-disp #.$XWRONGTYPE ,key-var ',types))) body)
+            (push `(t (setf ,keyform (ensure-value-of-type ,key-var ',types ',keyform))
+                      (go ,e-c-p)) body))))
     `(cond ,@(nreverse body))))