From 5928a7413d946a589f4f476eb24452712409c7cd Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <matthias@benkard.de>
Date: Sun, 3 Aug 2008 13:20:10 +0200
Subject: Add TYPECASE and ETYPECASE.

---
 types.lisp | 39 +++++++++++++++++++++++++++++++++------
 1 file changed, 33 insertions(+), 6 deletions(-)

(limited to 'types.lisp')

diff --git a/types.lisp b/types.lisp
index 91c8ac9..a73741f 100644
--- a/types.lisp
+++ b/types.lisp
@@ -26,7 +26,7 @@
           array simple-array simple-vector simple-string
           simple-bit-vector sequence two-way-stream stream echo-stream
           broadcast-stream file-stream synonym-stream string-stream
-          concatenated-stream deftype))
+          concatenated-stream deftype typecase etypecase))
 
 
 (setq *subtype-supertypes-dict*
@@ -117,18 +117,19 @@
                  (destructuring-lambda ,lambda-list ,@body)
                  ',type-name))
 
-(defun expand-type (type &optional environment)
-  (let* ((env (if rest (car rest) nil))
-         (expansion-1 (expand-type-1 object env))
+(defun expand-type (type &optional env)
+  (let* ((expansion-1 (expand-type-1 type env))
          (expansion-2 (expand-type-1 expansion-1 env)))
     (if (list-eqp expansion-1 expansion-2)
         expansion-1
         (expand-type expansion-2))))
 
 (defun expand-type-1 (type &optional environment)
-  (let ((expander (send-by-name *type-expanders* "objectForKey:" (first type))))
+  (let ((expander (send-by-name *type-expanders*
+                                "objectForKey:"
+                                (if (listp type) (first type) type))))
     (if expander
-        (apply expander (rest type))
+        (apply expander (if (listp type) (rest type) nil))
         type)))
 
 (defun typep (thing typespec &optional environment)
@@ -176,3 +177,29 @@
                                                  type1)))  ;strictly, this should be (nullify type1),
                                                            ;but type1 can't be NIL here
                    (some1 (lambda (x) (subtypep x type2 environment)) supertypes)))))))
+
+(defun numberp (x)
+  (typep x 'number))
+
+(defun characterp (x)
+  (typep x 'character))
+
+(defmacro typecase (expression &body cases)
+  (when cases
+    (let ((tmp (gensym))
+          (this-case (first cases))
+          (rest (rest cases)))
+      (if (and (null rest)
+               (or (eq (car this-case) t)
+                   (eq (car this-case) 'otherwise)))
+          `(progn ,@(cdr this-case))
+          `(let ((,tmp ,expression))
+             (if (typep ,tmp ',(car this-case))
+                 (progn ,@(cdr this-case))
+                 (typecase ,tmp ,@rest)))))))
+
+(defmacro etypecase (expression &body cases)
+  ;; FIXME: Incorrect.
+  `(typecase ,expression
+     ,@cases
+     (otherwise (error "~A fell through ETYPECASE expression" expression))))
-- 
cgit v1.2.3