Changeset 909

Feb 16, 2005, 7:05:59 PM (17 years ago)

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.

1 edited


  • trunk/ccl/lib/macros.lisp

    r903 r909  
    786786  (let* ((construct (if e-c-p (if (eq e-c-p 'etypecase) e-c-p 'ctypecase) 'typecase))
    787787         (types ())
    788          (t-clause ())
    789          (body ()))
     788         (body ())
     789         otherwise-seen-p)
    790790    (flet ((bad-clause (c)
    791791             (error "Invalid clause ~S in ~S form." c construct)))
    792792      (dolist (clause clauses)
    793793        (if (atom clause)
    794           (bad-clause clause)
    795           (destructuring-bind (typespec &body consequents) clause
    796             (when (eq construct 'typecase)
    797               (if (eq typespec 'otherwise)
    798                 (setq typespec t))
    799               (if (eq typespec t)
    800                 (if t-clause
    801                   (bad-clause clause)   ; seen one already
    802                   (setq t-clause `( t nil ,@consequents)))))
    803             (unless (and (eq construct 'typecase)
    804                          (eq typespec t))
    805               (when
    806                   (dolist (already types t)
    807                     (when (subtypep typespec already)
    808                       (warn "Clause ~S ignored in ~S form - shadowed by ~S ." clause construct (assq already clauses))
    809                       (return)))
    810                 (push typespec types)
    811                 (unless (eq typespec t)
    812                   (setq typespec `(typep ,key-var ',typespec)))
    813                 (push `(,typespec nil ,@consequents) body))))))
     794            (bad-clause clause))
     795        (if otherwise-seen-p
     796            (error "OTHERWISE must be final clause in ~S form." construct))
     797        (destructuring-bind (typespec &body consequents) clause
     798          (when (eq construct 'typecase)
     799            (if (eq typespec 'otherwise)
     800                (progn (setq typespec t)
     801                       (setq otherwise-seen-p t))))
     802          (unless
     803              (dolist (already types nil)
     804                (when (subtypep typespec already)
     805                  (warn "Clause ~S ignored in ~S form - shadowed by ~S ." clause construct (assq already clauses))
     806                  (return t)))
     807            (push typespec types)
     808            (setq typespec `(typep ,key-var ',typespec))
     809            (push `(,typespec nil ,@consequents) body))))
    814810      (when e-c-p
    815811        (setq types `(or ,@(nreverse types)))
    816812        (if (eq construct 'etypecase)
    817           (push `(t (values (%err-disp #.$XWRONGTYPE ,key-var ',types))) body)
    818           (push `(t (setf ,keyform (ensure-value-of-type ,key-var ',types ',keyform))
    819                   (go ,e-c-p)) body))))
    820     (when t-clause
    821       (push t-clause body))
     813            (push `(t (values (%err-disp #.$XWRONGTYPE ,key-var ',types))) body)
     814            (push `(t (setf ,keyform (ensure-value-of-type ,key-var ',types ',keyform))
     815                      (go ,e-c-p)) body))))
    822816    `(cond ,@(nreverse body))))
Note: See TracChangeset for help on using the changeset viewer.