X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Ftypep.lisp;h=c7d25a3ae805af0cff91dcdda45f8b64a83b5ff3;hb=1513b29bfbe948e7b431b5f67f1ff10769c192cf;hp=a21ec025455476393f5e2f9bd1019df69d61ba61;hpb=e58b011bbe611f10fbc316eea0a3e205c3e40ac7;p=sbcl.git

diff --git a/src/code/typep.lisp b/src/code/typep.lisp
index a21ec02..c7d25a3 100644
--- a/src/code/typep.lisp
+++ b/src/code/typep.lisp
@@ -117,9 +117,12 @@
      #+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))
@@ -136,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))
@@ -150,15 +155,7 @@
 	 (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