0.6.11.15:

[sbcl.git] / src / code / target-type.lisp

diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp
index 1e24030..de27d70 100644 (file)
--- a/src/code/target-type.lisp
+++ b/src/code/target-type.lisp
@@ -19,11 +19,6 @@
 ;;; a test that the host Lisp object OBJECT translates to a target SBCL
 ;;; type TYPE. (This behavior is needed e.g. to test for the validity of
 ;;; numeric subtype bounds read when cross-compiling.)
-;;;
-;;; KLUDGE: In classic CMU CL this was wrapped in a (DECLAIM (START-BLOCK
-;;; TYPEP %TYPEP CLASS-CELL-TYPEP)) to make calls efficient. Once I straighten
-;;; out bootstrapping and cross-compiling issues it'd likely be a good idea to
-;;; do this again. -- WHN 19990413
 (defun typep (object type)
   #!+sb-doc
   "Return T iff OBJECT is of type TYPE."
@@ -33,10 +28,15 @@
 ;;; return whether the object is of that type as the first value and
 ;;; second value true. Otherwise return NIL, NIL.
 ;;;
-;;; We give up on unknown types and pick off FUNCTION and UNION types.
-;;; For structure types, we require that the type be defined in both
-;;; the current and compiler environments, and that the INCLUDES be
-;;; the same.
+;;; We give up on unknown types and pick off FUNCTION- and COMPOUND-
+;;; types. For STRUCTURE- types, we require that the type be defined
+;;; in both the current and compiler environments, and that the
+;;; INCLUDES be the same.
+;;;
+;;; KLUDGE: This should probably be a type method instead of a big
+;;; ETYPECASE. But then the type method system should probably be CLOS
+;;; too, and until that happens wedging more stuff into it might be
+;;; messy. So I've left it a big ETYPECASE. -- 2001-03-16
 (defun ctypep (obj type)
   (declare (type ctype type))
   (etypecase type
@@ -44,7 +44,8 @@
         named-type
         member-type
         array-type
-        sb!xc:built-in-class)
+        sb!xc:built-in-class
+        cons-type)
      (values (%typep obj type) t))
     (sb!xc:class
      (if (if (csubtypep type (specifier-type 'funcallable-instance))
@@ -55,11 +56,29 @@
             (values (sb!xc:typep obj type) t)
             (values nil nil))
         (values nil t)))
-    (union-type
-     (dolist (mem (union-type-types type) (values nil t))
-       (multiple-value-bind (val win) (ctypep obj mem)
-        (unless win (return (values nil nil)))
-        (when val (return (values t t))))))
+    (compound-type
+     ;; REMOVEME: old version
+     #|
+     (let ((certain? t))
+       (etypecase type
+        (union-type
+         (dolist (mem (union-type-types type) (values nil certain?))
+           (multiple-value-bind (val win) (ctypep obj mem)
+             (if win
+                 (when val (return (values t t)))
+                 (setf certain? nil)))))
+        (intersection-type
+         (dolist (mem (intersection-type-types type)
+                      (if certain? (values t t) (values nil nil)))
+           (multiple-value-bind (val win) (ctypep obj mem)
+             (if win
+                 (unless val (return (values nil t)))
+                 (setf certain? nil)))))))
+     |#
+     (let ((types (compound-type-types type)))
+       (etypecase type
+        (intersection-type (every/type #'ctypep obj types))
+        (union-type        (any/type   #'ctypep obj types)))))
     (function-type
      (values (functionp obj) t))
     (unknown-type
@@ -146,8 +165,8 @@
 \f
 ;;;; miscellaneous interfaces
 
-;;; Clear memoization of all type system operations that can be altered by
-;;; type definition/redefinition.
+;;; Clear memoization of all type system operations that can be
+;;; altered by type definition/redefinition.
 (defun clear-type-caches ()
   (when *type-system-initialized*
     (dolist (sym '(values-specifier-type-cache-clear
@@ -155,14 +174,15 @@
                   type-union-cache-clear
                   values-subtypep-cache-clear
                   csubtypep-cache-clear
-                  type-intersection-cache-clear
+                  type-intersection2-cache-clear
                   values-type-intersection-cache-clear))
       (funcall (symbol-function sym))))
   (values))
 
-;;; Like TYPE-OF, only we return a CTYPE structure instead of a type specifier,
-;;; and we try to return the type most useful for type checking, rather than
-;;; trying to come up with the one that the user might find most informative.
+;;; Like TYPE-OF, only we return a CTYPE structure instead of a type
+;;; specifier, and we try to return the type most useful for type
+;;; checking, rather than trying to come up with the one that the user
+;;; might find most informative.
 (declaim (ftype (function (t) ctype) ctype-of))
 (defun-cached (ctype-of
               :hash-function (lambda (x) (logand (sxhash x) #x1FF))
@@ -201,6 +221,8 @@
                        :complexp (not (typep x 'simple-array))
                        :element-type etype
                        :specialized-element-type etype)))
+    (cons
+     (make-cons-type *universal-type* *universal-type*))
     (t
      (sb!xc:class-of x))))