Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 225:12579d965149 r20-4b11

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-4b11
author cvs
date Mon, 13 Aug 2007 10:11:40 +0200
parents 2c611d1463a6
children 57709be46d1b
comparison
equal deleted inserted replaced
224:4663b37daab6 225:12579d965149
449 place of a KEYLIST of one atom. A KEYLIST of `t' or `otherwise' is 449 place of a KEYLIST of one atom. A KEYLIST of `t' or `otherwise' is
450 allowed only in the final clause, and matches if no other keys match. 450 allowed only in the final clause, and matches if no other keys match.
451 Key values are compared by `eql'." 451 Key values are compared by `eql'."
452 (let* ((temp (if (cl-simple-expr-p expr 3) expr (gensym))) 452 (let* ((temp (if (cl-simple-expr-p expr 3) expr (gensym)))
453 (head-list nil) 453 (head-list nil)
454 (last-clause (car (last clauses)))
454 (body (cons 455 (body (cons
455 'cond 456 'cond
456 (mapcar 457 (mapcar
457 (function 458 (function
458 (lambda (c) 459 (lambda (c)
459 (cons (cond ((memq (car c) '(t otherwise)) t) 460 (cons (cond ((memq (car c) '(t otherwise))
461 (or (eq c last-clause)
462 (error
463 "`%s' is allowed only as the last case clause"
464 (car c)))
465 t)
460 ((eq (car c) 'ecase-error-flag) 466 ((eq (car c) 'ecase-error-flag)
461 (list 'error "ecase failed: %s, %s" 467 (list 'error "ecase failed: %s, %s"
462 temp (list 'quote (reverse head-list)))) 468 temp (list 'quote (reverse head-list))))
463 ((listp (car c)) 469 ((listp (car c))
464 (setq head-list (append (car c) head-list)) 470 (setq head-list (append (car c) head-list))
472 (or (cdr c) '(nil))))) 478 (or (cdr c) '(nil)))))
473 clauses)))) 479 clauses))))
474 (if (eq temp expr) body 480 (if (eq temp expr) body
475 (list 'let (list (list temp expr)) body)))) 481 (list 'let (list (list temp expr)) body))))
476 482
483 ;; #### CL standard also requires `ccase', which signals a continuable
484 ;; error (`cerror' in XEmacs). However, I don't think it buys us
485 ;; anything to introduce it, as there is probably much more CL stuff
486 ;; missing, and the feature is not essential. --hniksic
487
477 ;;;###autoload 488 ;;;###autoload
478 (defmacro ecase (expr &rest clauses) 489 (defmacro ecase (expr &rest clauses)
479 "(ecase EXPR CLAUSES...): like `case', but error if no case fits. 490 "(ecase EXPR CLAUSES...): like `case', but error if no case fits.
480 `otherwise'-clauses are not allowed." 491 `otherwise'-clauses are not allowed."
492 (let ((disallowed (or (assq t clauses)
493 (assq 'otherwise clauses))))
494 (if disallowed
495 (error "`%s' is not allowed in ecase" (car disallowed))))
481 (list* 'case expr (append clauses '((ecase-error-flag))))) 496 (list* 'case expr (append clauses '((ecase-error-flag)))))
482 497
483 ;;;###autoload 498 ;;;###autoload
484 (defmacro typecase (expr &rest clauses) 499 (defmacro typecase (expr &rest clauses)
485 "(typecase EXPR CLAUSES...): evals EXPR, chooses from CLAUSES on that value. 500 "(typecase EXPR CLAUSES...): evals EXPR, chooses from CLAUSES on that value.