Improve TYPEP performance.

1 files changed, 50 insertions, 52 deletions

diff --git a/types.lisp b/types.lisp
index 3f8780a..22c9940 100644
--- a/types.lisp
+++ b/types.lisp
@@ -11,40 +11,38 @@
 ;(defvar *type-table*)
 
 (setq *subtype-relationships*
-      '((real . number)
-        (complex . number)
-        (rational . real)
-        (float . real)
-        (integer . rational)
-        (ratio . rational)
-        (fixnum . integer)
-        (bignum . integer)
-        (short-float . float)
-        (long-float . float)
-        (single-float . float)
-        (double-float . float)
-        (null . symbol)
-        (null . list)
-        (cons . list)
-        (standard-char . base-char)
-        (base-char . character)
-        (extended-char . character)
-        (string . vector)
-        (bit-vector . vector)
-        (vector . array)
-        (simple-array . array)
-        (simple-vector . simple-array)
-        (simple-string . simple-array)
-        (simple-bit-vector . simple-array)
-        (vector . sequence)
-        (list . sequence)
-        (two-way-stream . stream)
-        (echo-stream . stream)
-        (broadcast-stream . stream)
-        (file-stream . stream)
-        (synonym-stream . stream)
-        (string-stream . stream)
-        (concatenated-stream . stream)))
+      '((base-char . (character))
+        (bignum . (integer))
+        (bit-vector . (vector))
+        (broadcast-stream . (stream))
+        (complex . (number))
+        (concatenated-stream . (stream))
+        (cons . (list))
+        (double-float . (float))
+        (echo-stream . (stream))
+        (extended-char . (character))
+        (file-stream . (stream))
+        (fixnum . (integer))
+        (float . (real))
+        (integer . (rational))
+        (list . (sequence))
+        (long-float . (float))
+        (null . (list symbol))
+        (ratio . (rational))
+        (rational . (real))
+        (real . (number))
+        (short-float . (float))
+        (simple-array . (array))
+        (simple-bit-vector . (simple-array))
+        (simple-string . (simple-array))
+        (simple-vector . (simple-array))
+        (single-float . (float))
+        (standard-char . (base-char))
+        (string . (vector))
+        (string-stream . (stream))
+        (synonym-stream . (stream))
+        (two-way-stream . (stream))
+        (vector . (array sequence))))
 
 
 (setq most-positive-fixnum 32767)
@@ -95,7 +93,7 @@
            (every1 function (rest list)))))
 
 
-(defun expand-type (type)
+(defun expand-type (type &optional environment)
   ;;FIXME: DEFTYPE
   type)
 
@@ -103,22 +101,25 @@
 (defun typep (thing typespec &optional environment)
   ;;FIXME: DEFTYPE
   (let ((type (type-of thing))
-        (typespec (expand-type typespec)))
-    (if (listp typespec)
-        (case (first typespec)
-          (and (every1 (lambda (x) (typep thing x environment)) (rest typespec)))
-          (or (some1 (lambda (x) (typep thing x environment)) (rest typespec)))
-          (not (not (typep thing (second typespec) environment)))
-          (satisfies (funcall (second typespec) thing))
-          (otherwise
-           (subtypep type typespec environment)))
-        (subtypep type typespec environment))))
+        (typespec (expand-type typespec environment)))
+    (cond ((eq typespec t) t)
+          ((listp typespec)
+           (case (first typespec)
+             (and (every1 (lambda (x) (typep thing x environment)) (rest typespec)))
+             (or (some1 (lambda (x) (typep thing x environment)) (rest typespec)))
+             (not (not (typep thing (second typespec) environment)))
+             (satisfies (funcall (second typespec) thing))
+             (otherwise
+              (subtypep type typespec environment))))
+          (t (subtypep type typespec environment)))))
 
 
 (defun subtypep (type1 type2 &optional environment)
-  (let ((type1 (expand-type type1))
-        (type2 (expand-type type2)))
-    (cond ((listp type1)
+  (let ((type1 (expand-type type1 environment))
+        (type2 (expand-type type2 environment)))
+    (cond ((eq type2 t) t)
+          ((eq type1 nil) t)
+          ((listp type1)
            (case (first type1)
              (and (some1 (lambda (x) (subtypep x type2 environment)) (rest type1)))
              (or (every1 (lambda (x) (subtypep x type2 environment)) (rest type1)))
@@ -137,8 +138,5 @@
               ;;FIXME?
               (subtypep type1 (first type2) environment))))
           (t (or (eq type1 type2)
-                 (let ((supertypes (mapcan1 (lambda (x)
-                                              (when (eq (car x) type1)
-                                                (list (cdr x))))
-                                            *subtype-relationships*)))
+                 (let ((supertypes (assoc type1 *subtype-relationships* :test 'eq)))
                    (some1 (lambda (x) (subtypep x type2 environment)) supertypes)))))))