[Bug-openmcl] reworked typecase patch

[bryan o'connor]

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.

? (typecase 3
	(t 'correct)
	(number 'wrong))
; Warning: Clause (NUMBER 'WRONG) ignored in TYPECASE form - shadowed 
by (T 'CORRECT) .
; While executing: CCL::TYPECASE-AUX
CORRECT

? (macroexpand-1 '(typecase 3 (t 'correct) (number 'wrong)))
[...]
(LET ((#:G1 3)) (DECLARE (IGNORABLE #:G1)) (COND ((TYPEP #:G1 'T) NIL 
'CORRECT)))

? (typecase 3 (otherwise 'wrong) (number 'correct))
 > Error in process listener(1): OTHERWISE must be final clause in 
TYPECASE form.
 > While executing: CCL::TYPECASE-AUX


	...bryan


-------------- next part --------------
Index: lib/macros.lisp
===================================================================
RCS file: /usr/local/tmpcvs/ccl-0.14-dev/ccl/lib/macros.lisp,v
retrieving revision 1.20
diff -c -r1.20 macros.lisp
*** lib/macros.lisp	25 Sep 2004 21:36:06 -0000	1.20
--- lib/macros.lisp	14 Dec 2004 22:49:39 -0000
***************
*** 785,824 ****
  (defun typecase-aux (key-var clauses &optional e-c-p keyform)
    (let* ((construct (if e-c-p (if (eq e-c-p 'etypecase) e-c-p 'ctypecase) 'typecase))
           (types ())
!          (t-clause ())
!          (body ()))
      (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 , at 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 , at 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))
      `(cond ,@(nreverse body))))
  
  (defmacro typecase (keyform &body clauses)
--- 785,818 ----
  (defun typecase-aux (key-var clauses &optional e-c-p keyform)
    (let* ((construct (if e-c-p (if (eq e-c-p 'etypecase) e-c-p 'ctypecase) 'typecase))
           (types ())
!          (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))
!         (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))))
!           (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)
!           (setq typespec `(typep ,key-var ',typespec))
!           (push `(,typespec nil , at 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))))
      `(cond ,@(nreverse body))))
  
  (defmacro typecase (keyform &body clauses)
-------------- next part --------------