From 334494040045f226225f6bbcef65b40b1e5c8083 Mon Sep 17 00:00:00 2001 From: toy <toy> Date: Wed, 7 Aug 2002 15:19:47 +0000 Subject: [PATCH] ECASE and CCASE are allowed to use T and OTHERWISE as regular keys instead of as the otherwise-clause. Print a simple warning about this being bad style. --- code/macros.lisp | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/code/macros.lisp b/code/macros.lisp index 28b6827c0..152ee9aaf 100644 --- a/code/macros.lisp +++ b/code/macros.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.73 2002/07/25 14:50:24 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.74 2002/08/07 15:19:47 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1204,14 +1204,19 @@ ;;; to omit errorp, and the ERROR form generated is executed within a ;;; RESTART-CASE allowing keyform to be set and retested. ;;; -(defun case-body (name keyform cases multi-p test errorp proceedp) +;;; If ALLOW-OTHERWISE, then we allow T and OTHERWISE clauses and also +;;; generate an ERROR form. (This is for CCASE and ECASE which allow +;;; using T and OTHERWISE as regular keys.) +;;; +(defun case-body (name keyform cases multi-p test errorp proceedp &optional allow-otherwise) (let ((keyform-value (gensym)) (clauses ()) (keys ())) (dolist (case cases) (cond ((atom case) (error "~S -- Bad clause in ~S." case name)) - ((memq (car case) '(t otherwise)) + ((and (not allow-otherwise) + (memq (car case) '(t otherwise))) (if errorp (error "No default clause allowed in ~S: ~S" name case) (push `(t nil ,@(rest case)) clauses))) @@ -1223,10 +1228,14 @@ nil ,@(rest case)) clauses)) (t + (when (and allow-otherwise + (memq (car case) '(t otherwise))) + (warn "Bad style to use T or OTHERWISE in ECASE or CCASE")) (push (first case) keys) (push `((,test ,keyform-value ',(first case)) nil ,@(rest case)) clauses)))) (case-body-aux name keyform keyform-value clauses keys errorp proceedp + allow-otherwise `(,(if multi-p 'member 'or) ,@keys)))) ;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled all the @@ -1237,7 +1246,7 @@ ;;; any function using the case macros, regardless of whether they are needed. ;;; (defun case-body-aux (name keyform keyform-value clauses keys - errorp proceedp expected-type) + errorp proceedp allow-otherwise expected-type) (if proceedp (let ((block (gensym)) (again (gensym))) @@ -1259,7 +1268,7 @@ ,keyform-value ; prevent warnings when key not used eg (case key (t)) (cond ,@(nreverse clauses) - ,@(if errorp + ,@(if (or errorp allow-otherwise) `((t (error 'conditions::case-failure :name ',name :datum ,keyform-value @@ -1293,13 +1302,13 @@ Evaluates the Forms in the first clause with a Key EQL to the value of Keyform. If none of the keys matches then a correctable error is signalled." - (case-body 'ccase keyform cases t 'eql t t)) + (case-body 'ccase keyform cases t 'eql nil t t)) (defmacro ecase (keyform &body cases) "ECASE Keyform {({(Key*) | Key} Form*)}* Evaluates the Forms in the first clause with a Key EQL to the value of Keyform. If none of the keys matches then an error is signalled." - (case-body 'ecase keyform cases t 'eql t nil)) + (case-body 'ecase keyform cases t 'eql nil nil t)) (defmacro typecase (keyform &body cases) "TYPECASE Keyform {(Type Form*)}* -- GitLab