- (cond ((and (memq keyoid '(t otherwise))
- (null (cdr cases)))
- (if errorp
- (progn
- (style-warn "~@<Treating bare ~A in ~A as introducing a ~
- normal-clause, not an otherwise-clause~@:>"
- keyoid name)
- (push keyoid keys)
- (push `((,test ,keyform-value ',keyoid) nil ,@forms)
- clauses))
- (push `(t nil ,@forms) clauses)))
- ((and multi-p (listp keyoid))
- (setf keys (append keyoid keys))
- (push `((or ,@(mapcar (lambda (key)
- `(,test ,keyform-value ',key))
- keyoid))
- nil
- ,@forms)
- clauses))
- (t
- (push keyoid keys)
- (push `((,test ,keyform-value ',keyoid)
- nil
- ,@forms)
- clauses)))))
+ (cond (;; an OTHERWISE-CLAUSE
+ ;;
+ ;; By the way... The old code here tried gave
+ ;; STYLE-WARNINGs for normal-clauses which looked as
+ ;; though they might've been intended to be
+ ;; otherwise-clauses. As Tony Martinez reported on
+ ;; sbcl-devel 2004-11-09 there are sometimes good
+ ;; reasons to write clauses like that; and as I noticed
+ ;; when trying to understand the old code so I could
+ ;; understand his patch, trying to guess which clauses
+ ;; don't have good reasons is fundamentally kind of a
+ ;; mess. SBCL does issue style warnings rather
+ ;; enthusiastically, and I have often justified that by
+ ;; arguing that we're doing that to detect issues which
+ ;; are tedious for programmers to detect for by
+ ;; proofreading (like small typoes in long symbol
+ ;; names, or duplicate function definitions in large
+ ;; files). This doesn't seem to be an issue like that,
+ ;; and I can't think of a comparably good justification
+ ;; for giving STYLE-WARNINGs for legal code here, so
+ ;; now we just hope the programmer knows what he's
+ ;; doing. -- WHN 2004-11-20
+ (and (not errorp) ; possible only in CASE or TYPECASE,
+ ; not in [EC]CASE or [EC]TYPECASE
+ (memq keyoid '(t otherwise))
+ (null (cdr cases)))
+ (push `(t nil ,@forms) clauses))
+ ((and multi-p (listp keyoid))
+ (setf keys (append keyoid keys))
+ (push `((or ,@(mapcar (lambda (key)
+ `(,test ,keyform-value ',key))
+ keyoid))
+ nil
+ ,@forms)
+ clauses))
+ (t
+ (push keyoid keys)
+ (push `((,test ,keyform-value ',keyoid)
+ nil
+ ,@forms)
+ clauses)))))