X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftypep.lisp;h=6807198ad9341bc703c22f7ec63c5adb78931d27;hb=5d6eb238f2d59e6df825cb03aefe2976a130c6ec;hp=8c58facaeaeeb1a57c95e193b602b06ed8758a99;hpb=e240e076bc5bfa07a408a89d2e354e7ec9ff9341;p=sbcl.git

diff --git a/src/code/typep.lisp b/src/code/typep.lisp
index 8c58fac..6807198 100644
--- a/src/code/typep.lisp
+++ b/src/code/typep.lisp
@@ -9,7 +9,21 @@
 
 (in-package "SB!KERNEL")
 
-;;; The actual TYPEP engine. The compiler only generates calls to this
+;;; (Note that when cross-compiling, SB!XC:TYPEP is interpreted as 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.)
+(defun typep (object type)
+  #!+sb-doc
+  "Is OBJECT of type TYPE?"
+  ;; Actually interpreting types at runtime is done by %TYPEP. The
+  ;; cost of the extra function call here should be negligible
+  ;; compared to the cost of interpreting types. (And the compiler
+  ;; tries hard to optimize away the interpretation of types at
+  ;; runtime, and when it succeeds, we never get here anyway.)
+  (%typep object type))
+
+;;; 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
@@ -25,7 +39,14 @@
        ((nil) nil)))
     (numeric-type
      (and (numberp object)
-	  (let ((num (if (complexp object) (realpart object) object)))
+	  (let (;; I think this works because of an invariant of the
+		;; two components of a COMPLEX are always coerced to
+		;; be the same, e.g. (COMPLEX 1.0 3/2) => #C(1.0 1.5).
+		;; Dunno why that holds, though -- ANSI? Python
+		;; tradition? marsh faerie spirits? -- WHN 2001-10-27
+		(num (if (complexp object)
+			 (realpart object)
+			 object)))
 	    (ecase (numeric-type-class type)
 	      (integer (integerp num))
 	      (rational (rationalp num))
@@ -101,6 +122,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
@@ -111,9 +138,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))
@@ -130,13 +160,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))
@@ -144,22 +176,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)))
@@ -167,12 +191,12 @@
       (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)
     (if (and (typep (sb!xc:class-of object) 'sb!xc:standard-class) object)
-	(setq obj-layout (pcl-check-wrapper-validity-hook object))
+	(setq obj-layout (sb!pcl::check-wrapper-validity object))
 	(error "TYPEP was called on an obsolete object (was class ~S)."
 	       (class-proper-name (layout-class obj-layout)))))
   (let ((layout (class-layout class))
@@ -184,8 +208,7 @@
 	  (when (eq (svref obj-inherits i) layout)
 	    (return t))))))
 
-;;; to be redefined as PCL::CHECK-WRAPPER-VALIDITY when PCL is loaded
-;;;
-;;; FIXME: should probably be renamed SB!PCL:CHECK-WRAPPER-VALIDITY
-(defun pcl-check-wrapper-validity-hook (object)
+;;; This implementation is a placeholder to use until PCL is set up,
+;;; at which time it will be overwritten by a real implementation.
+(defun sb!pcl::check-wrapper-validity (object)
   object)