From e5e835abccc2a05d4e5b57c05b3f5844373d8b75 Mon Sep 17 00:00:00 2001
From: Juan Jose Garcia Ripoll <jjgarcia@users.sourceforge.net>
Date: Sat, 5 Jun 2010 11:27:54 +0200
Subject: [PATCH] New special form COMPILER-TYPECASES

---
 src/cmp/cmpopt-type.lsp | 35 ++++++++++++++++++++++++-----------
 src/cmp/cmptables.lsp   |  1 +
 2 files changed, 25 insertions(+), 11 deletions(-)

diff --git a/src/cmp/cmpopt-type.lsp b/src/cmp/cmpopt-type.lsp
index b25b548f8..9a6b65fb9 100644
--- a/src/cmp/cmpopt-type.lsp
+++ b/src/cmp/cmpopt-type.lsp
@@ -14,18 +14,31 @@
 
 (in-package "COMPILER")
 
+(defun compute-c1form-type (form)
+  (let ((form (c1expr form)))
+    (prog1 (c1form-primary-type form)
+      (delete-c1forms form))))
+
+(defun safe-type<= (t1 t2)
+  (multiple-value-bind (subtypep known-typep)
+      (subtypep t1 t2)
+    (and subtypep known-typep)))
+
 (defun c1compiler-typecase (args)
-  (or (loop with expr-type = (let ((form (c1expr (pop args))))
-                               (prog1 (c1form-primary-type form)
-                                 (delete-c1forms form)))
-         with subtypep
-         with known-typep
-         for (type . body) in args
-         when (multiple-value-bind (subtypep known-typep)
-                  (subtypep expr-type type)
-                (and subtypep known-typep))
-         return (c1progn body))
-      (c1nil)))
+  (let* ((expr-type (compute-c1form-type (pop args)))
+         (match (find expr-type args :test #'safe-type<= :key #'first)))
+    (if match
+        (c1progn (rest match))
+        (c1nil))))
+
+(defun c1compiler-typecases (args)
+  (let* ((all-types (mapcar #'compute-c1form-type (pop args)))
+         (match (find expr-type args
+                      :test #'(lambda (s1 s2) (every #'safe-typep<= s1 s2))
+                      :key #'first)))
+    (if match
+        (c1progn (rest match))
+        (c1nil))))
 
 (define-compiler-macro dotimes ((variable limit &rest output) &body body)
   (multiple-value-bind (declarations body)
diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp
index 9dd174317..15cf4c717 100644
--- a/src/cmp/cmptables.lsp
+++ b/src/cmp/cmptables.lsp
@@ -46,6 +46,7 @@
     (multiple-value-bind . c1multiple-value-bind) ; c1
 
     (ext:compiler-typecase . c1compiler-typecase) ; c1special
+    (c::compiler-typecases . c1compiler-typecases) ; c1special
 
     (quote . c1quote) ; c1special
     (function . c1function) ; c1special