0.pre7.67:

[sbcl.git] / src / code / typep.lisp

diff --git a/src/code/typep.lisp b/src/code/typep.lisp
index 505b55c..bec03ac 100644 (file)
--- a/src/code/typep.lisp
+++ b/src/code/typep.lisp
@@ -9,10 +9,7 @@
 
 (in-package "SB!KERNEL")
 
-(file-comment
-  "$Header$")
-
-;;; The actual TYPEP engine. The compiler only generates calls to this
+;;; the actual TYPEP engine. The compiler only generates calls to this
 ;;; function when it can't figure out anything more intelligent to do.
 (defun %typep (object specifier)
   (%%typep object
@@ -104,6 +101,12 @@
                             (or (eq (car want) '*)
                                 (= (car want) (car got))))
                  (return nil))))
+         (if (unknown-type-p (array-type-element-type type))
+             ;; better to fail this way than to get bogosities like
+             ;;   (TYPEP (MAKE-ARRAY 11) '(ARRAY SOME-UNDEFINED-TYPE)) => T
+             (error "~@<unknown element type in array type: ~2I~_~S~:>"
+                    (type-specifier type))
+             t)
          (or (eq (array-type-element-type type) *wild-type*)
              (values (type= (array-type-specialized-element-type type)
                             (specifier-type (array-element-type
@@ -114,9 +117,16 @@
      #+sb-xc-host (ctypep object type)
      #-sb-xc-host (class-typep (layout-of object) type object))
     (union-type
-     (dolist (type (union-type-types type))
-       (when (%%typep object type)
-        (return t))))
+     (some (lambda (union-type-type) (%%typep object union-type-type))
+          (union-type-types type)))
+    (intersection-type
+     (every (lambda (intersection-type-type)
+             (%%typep object intersection-type-type))
+           (intersection-type-types type)))
+    (cons-type
+     (and (consp object)
+         (%%typep (car object) (cons-type-car-type type))
+         (%%typep (cdr object) (cons-type-cdr-type type))))
     (unknown-type
      ;; dunno how to do this ANSIly -- WHN 19990413
      #+sb-xc-host (error "stub: %%TYPEP UNKNOWN-TYPE in xcompilation host")
@@ -129,13 +139,15 @@
     (hairy-type
      ;; Now the tricky stuff.
      (let* ((hairy-spec (hairy-type-specifier type))
-           (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
+           (symbol (car hairy-spec)))
        (ecase symbol
         (and
-         (or (atom hairy-spec)
-             (dolist (spec (cdr hairy-spec) t)
-               (unless (%%typep object (specifier-type spec))
-                 (return nil)))))
+         (every (lambda (spec) (%%typep object (specifier-type spec)))
+                (rest hairy-spec)))
+        ;; Note: it should be safe to skip OR here, because union
+        ;; types can always be represented as UNION-TYPE in general
+        ;; or other CTYPEs in special cases; we never need to use
+        ;; HAIRY-TYPE for them.
         (not
          (unless (proper-list-of-length-p hairy-spec 2)
            (error "invalid type specifier: ~S" hairy-spec))
@@ -143,22 +155,14 @@
         (satisfies
          (unless (proper-list-of-length-p hairy-spec 2)
            (error "invalid type specifier: ~S" hairy-spec))
-         (let ((fn (cadr hairy-spec)))
-           (if (funcall (typecase fn
-                          (function fn)
-                          (symbol (symbol-function fn))
-                          (t
-                           (coerce fn 'function)))
-                        object)
-               t
-               nil))))))
+         (values (funcall (symbol-function (cadr hairy-spec)) object))))))
     (alien-type-type
      (sb!alien-internals:alien-typep object (alien-type-type-alien-type type)))
-    (function-type
+    (fun-type
      (error "Function types are not a legal argument to TYPEP:~%  ~S"
            (type-specifier type)))))
 
-;;; Do type test from a class cell, allowing forward reference and
+;;; Do a type test from a class cell, allowing forward reference and
 ;;; redefinition.
 (defun class-cell-typep (obj-layout cell object)
   (let ((class (class-cell-class cell)))
@@ -166,7 +170,7 @@
       (error "The class ~S has not yet been defined." (class-cell-name cell)))
     (class-typep obj-layout class object)))
 
-;;; Test whether Obj-Layout is from an instance of Class.
+;;; Test whether OBJ-LAYOUT is from an instance of CLASS.
 (defun class-typep (obj-layout class object)
   (declare (optimize speed))
   (when (layout-invalid obj-layout)