/[cmucl]/src/code/macros.lisp
ViewVC logotype

Diff of /src/code/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.73 by toy, Thu Jul 25 14:50:24 2002 UTC revision 1.74 by toy, Wed Aug 7 15:19:47 2002 UTC
# Line 1204  Line 1204 
1204  ;;; to omit errorp, and the ERROR form generated is executed within a  ;;; to omit errorp, and the ERROR form generated is executed within a
1205  ;;; RESTART-CASE allowing keyform to be set and retested.  ;;; RESTART-CASE allowing keyform to be set and retested.
1206  ;;;  ;;;
1207  (defun case-body (name keyform cases multi-p test errorp proceedp)  ;;; If ALLOW-OTHERWISE, then we allow T and OTHERWISE clauses and also
1208    ;;; generate an ERROR form.  (This is for CCASE and ECASE which allow
1209    ;;; using T and OTHERWISE as regular keys.)
1210    ;;;
1211    (defun case-body (name keyform cases multi-p test errorp proceedp &optional allow-otherwise)
1212    (let ((keyform-value (gensym))    (let ((keyform-value (gensym))
1213          (clauses ())          (clauses ())
1214          (keys ()))          (keys ()))
1215      (dolist (case cases)      (dolist (case cases)
1216        (cond ((atom case)        (cond ((atom case)
1217               (error "~S -- Bad clause in ~S." case name))               (error "~S -- Bad clause in ~S." case name))
1218              ((memq (car case) '(t otherwise))              ((and (not allow-otherwise)
1219                     (memq (car case) '(t otherwise)))
1220               (if errorp               (if errorp
1221                   (error "No default clause allowed in ~S: ~S" name case)                   (error "No default clause allowed in ~S: ~S" name case)
1222                   (push `(t nil ,@(rest case)) clauses)))                   (push `(t nil ,@(rest case)) clauses)))
# Line 1223  Line 1228 
1228                       nil ,@(rest case))                       nil ,@(rest case))
1229                     clauses))                     clauses))
1230              (t              (t
1231                 (when (and allow-otherwise
1232                            (memq (car case) '(t otherwise)))
1233                   (warn "Bad style to use T or OTHERWISE in ECASE or CCASE"))
1234               (push (first case) keys)               (push (first case) keys)
1235               (push `((,test ,keyform-value               (push `((,test ,keyform-value
1236                              ',(first case)) nil ,@(rest case)) clauses))))                              ',(first case)) nil ,@(rest case)) clauses))))
1237      (case-body-aux name keyform keyform-value clauses keys errorp proceedp      (case-body-aux name keyform keyform-value clauses keys errorp proceedp
1238                       allow-otherwise
1239                     `(,(if multi-p 'member 'or) ,@keys))))                     `(,(if multi-p 'member 'or) ,@keys))))
1240    
1241  ;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled all the  ;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled all the
# Line 1237  Line 1246 
1246  ;;; any function using the case macros, regardless of whether they are needed.  ;;; any function using the case macros, regardless of whether they are needed.
1247  ;;;  ;;;
1248  (defun case-body-aux (name keyform keyform-value clauses keys  (defun case-body-aux (name keyform keyform-value clauses keys
1249                        errorp proceedp expected-type)                        errorp proceedp allow-otherwise expected-type)
1250    (if proceedp    (if proceedp
1251        (let ((block (gensym))        (let ((block (gensym))
1252              (again (gensym)))              (again (gensym)))
# Line 1259  Line 1268 
1268           ,keyform-value ; prevent warnings when key not used eg (case key (t))           ,keyform-value ; prevent warnings when key not used eg (case key (t))
1269           (cond           (cond
1270            ,@(nreverse clauses)            ,@(nreverse clauses)
1271            ,@(if errorp            ,@(if (or errorp allow-otherwise)
1272                  `((t (error 'conditions::case-failure                  `((t (error 'conditions::case-failure
1273                              :name ',name                              :name ',name
1274                              :datum ,keyform-value                              :datum ,keyform-value
# Line 1293  Line 1302 
1302    Evaluates the Forms in the first clause with a Key EQL to the value of    Evaluates the Forms in the first clause with a Key EQL to the value of
1303    Keyform.  If none of the keys matches then a correctable error is    Keyform.  If none of the keys matches then a correctable error is
1304    signalled."    signalled."
1305    (case-body 'ccase keyform cases t 'eql t t))    (case-body 'ccase keyform cases t 'eql nil t t))
1306    
1307  (defmacro ecase (keyform &body cases)  (defmacro ecase (keyform &body cases)
1308    "ECASE Keyform {({(Key*) | Key} Form*)}*    "ECASE Keyform {({(Key*) | Key} Form*)}*
1309    Evaluates the Forms in the first clause with a Key EQL to the value of    Evaluates the Forms in the first clause with a Key EQL to the value of
1310    Keyform.  If none of the keys matches then an error is signalled."    Keyform.  If none of the keys matches then an error is signalled."
1311    (case-body 'ecase keyform cases t 'eql t nil))    (case-body 'ecase keyform cases t 'eql nil nil t))
1312    
1313  (defmacro typecase (keyform &body cases)  (defmacro typecase (keyform &body cases)
1314    "TYPECASE Keyform {(Type Form*)}*    "TYPECASE Keyform {(Type Form*)}*

Legend:
Removed from v.1.73  
changed lines
  Added in v.1.74

  ViewVC Help
Powered by ViewVC 1.1.5