Changeset 4993


Ignore:
Timestamp:
12/06/03 15:47:24 (17 years ago)
Author:
piso
Message:

case.lisp

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/boot.lisp

    r4990 r4993  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: boot.lisp,v 1.133 2003-12-06 14:10:57 piso Exp $
     4;;; $Id: boot.lisp,v 1.134 2003-12-06 15:47:24 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    202202      (or ,@(rest forms))))))))
    203203
    204 
    205 ;; CASE (from CLISP)
    206 
    207 (defun case-expand (form-name test keyform clauses)
    208   (let ((var (gensym)))
    209     `(let ((,var ,keyform))
    210        (cond
    211         ,@(maplist
    212            #'(lambda (remaining-clauses)
    213               (let ((clause (first remaining-clauses))
    214                     (remaining-clauses (rest remaining-clauses)))
    215                 (unless (consp clause)
    216                   (error 'program-error "~S: missing key list" form-name))
    217                 (let ((keys (first clause)))
    218                   `(,(cond ((or (eq keys 'T) (eq keys 'OTHERWISE))
    219                             (if remaining-clauses
    220                                 (error 'program-error
    221                                        "~S: the ~S clause must be the last one"
    222                                        form-name keys)
    223                                 't))
    224                            ((listp keys)
    225                             `(or ,@(mapcar #'(lambda (key)
    226                                               `(,test ,var ',key))
    227                                            keys)))
    228                            (t `(,test ,var ',keys)))
    229                      ,@(rest clause)))))
    230            clauses)))))
    231 
    232 (defmacro case (keyform &rest clauses)
    233   (case-expand 'case 'eql keyform clauses))
    234 
    235 
    236 ;; CCASE (from CLISP)
    237 
    238 (defun parenthesize-keys (clauses)
    239   ;; PARENTHESIZE-KEYS is necessary to avoid confusing
    240   ;; the symbols OTHERWISE and T used as keys, with the same
    241   ;; symbols used in the syntax of the non exhaustive CASE.
    242   (mapcar #'(lambda (c)
    243              (cond ((or (eq (car c) 't)
    244                         (eq (car c) 'otherwise))
    245                     (cons (list (car c)) (cdr c)))
    246                    (t c)))
    247           clauses))
    248 
    249 (defmacro ccase (keyplace &rest clauses)
    250   (let ((g (gensym))
    251         (h (gensym)))
    252     `(block ,g
    253             (tagbody
    254              ,h
    255              (return-from ,g
    256                           (case ,keyplace
    257                             ,@(parenthesize-keys clauses)
    258                             (otherwise
    259                              (error 'type-error "CCASE error") ;; FIXME
    260                              (go ,h))))))))
    261 
    262 
    263 ;;; TYPECASE (from CLISP)
    264 
    265 (defmacro typecase (keyform &rest typeclauselist)
    266   (let* ((tempvar (gensym))
    267          (condclauselist nil))
    268     (do ((typeclauselistr typeclauselist (cdr typeclauselistr)))
    269         ((atom typeclauselistr))
    270       (cond ((atom (car typeclauselistr))
    271              (error 'program-error
    272                     "invalid clause in ~S: ~S"
    273                     'typecase (car typeclauselistr)))
    274             ((let ((type (caar typeclauselistr)))
    275                (or (eq type T) (eq type 'OTHERWISE)))
    276              (push `(T ,@(or (cdar typeclauselistr) '(NIL))) condclauselist)
    277              (return))
    278             (t (push `((TYPEP ,tempvar (QUOTE ,(caar typeclauselistr)))
    279                        ,@(or (cdar typeclauselistr) '(NIL)))
    280                      condclauselist))))
    281     `(LET ((,tempvar ,keyform)) (COND ,@(nreverse condclauselist)))))
    282 
    283 
    284 (defmacro etypecase (keyform &rest clauses)
    285   (let ((var (gensym)))
    286     `(let ((,var ,keyform))
    287        (typecase ,var
    288          ,@clauses
    289          (otherwise
    290           (error 'type-error "~S fell through ETYPECASE expression" ,var))))))
    291 
    292 
    293 (defmacro ctypecase (keyplace &rest clauses)
    294   (let ((g (gensym))
    295         (h (gensym)))
    296     `(block ,g
    297             (tagbody
    298              ,h
    299              (return-from ,g
    300                           (typecase ,keyplace
    301                             ,@clauses
    302                             (otherwise
    303                              (error 'type-error "CTYPECASE error") ;; FIXME
    304                              (go ,h))))))))
    305 
     204(sys::%load "case.lisp")
    306205
    307206(defmacro cond (&rest clauses)
Note: See TracChangeset for help on using the changeset viewer.