X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftypep.lisp;h=0df87b1c2f89099f845d35ef37ee4d2a01423e3e;hb=2034cb134af58c5998f4e305673af6e2c75bc179;hp=c7d25a3ae805af0cff91dcdda45f8b64a83b5ff3;hpb=ce02ab2ecd9c6ae2e570abd8c93ebf3be55bbdad;p=sbcl.git

diff --git a/src/code/typep.lisp b/src/code/typep.lisp
index c7d25a3..0df87b1 100644
--- a/src/code/typep.lisp
+++ b/src/code/typep.lisp
@@ -9,6 +9,21 @@
 
 (in-package "SB!KERNEL")
 
+;;; (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 &optional environment)
+  #!+sb-doc
+  "Is OBJECT of type TYPE?"
+  (declare (ignore environment))
+  ;; 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)
@@ -25,7 +40,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))
@@ -37,7 +59,6 @@
 		 (long-float (typep num 'long-float))
 		 ((nil) (floatp num))))
 	      ((nil) t)))
-	  #!-negative-zero-is-not-zero
 	  (flet ((bound-test (val)
 		   (let ((low (numeric-type-low type))
 			 (high (numeric-type-high type)))
@@ -55,37 +76,6 @@
 		    (bound-test (imagpart object))))
 	      (:real
 	       (and (not (complexp object))
-		    (bound-test object)))))
-	  #!+negative-zero-is-not-zero
-	  (labels ((signed-> (x y)
-		     (if (and (zerop x) (zerop y) (floatp x) (floatp y))
-			 (> (float-sign x) (float-sign y))
-			 (> x y)))
-		   (signed->= (x y)
-		     (if (and (zerop x) (zerop y) (floatp x) (floatp y))
-			 (>= (float-sign x) (float-sign y))
-			 (>= x y)))
-		   (bound-test (val)
-		     (let ((low (numeric-type-low type))
-			   (high (numeric-type-high type)))
-		       (and (cond ((null low) t)
-				  ((listp low)
-				   (signed-> val (car low)))
-				  (t
-				   (signed->= val low)))
-			    (cond ((null high) t)
-				  ((listp high)
-				   (signed-> (car high) val))
-				  (t
-				   (signed->= high val)))))))
-	    (ecase (numeric-type-complexp type)
-	      ((nil) t)
-	      (:complex
-	       (and (complexp object)
-		    (bound-test (realpart object))
-		    (bound-test (imagpart object))))
-	      (:real
-	       (and (not (complexp object))
 		    (bound-test object)))))))
     (array-type
      (and (arrayp object)
@@ -113,9 +103,9 @@
 					      object)))))))
     (member-type
      (if (member object (member-type-members type)) t))
-    (sb!xc:class
+    (classoid
      #+sb-xc-host (ctypep object type)
-     #-sb-xc-host (class-typep (layout-of object) type object))
+     #-sb-xc-host (classoid-typep (layout-of object) type object))
     (union-type
      (some (lambda (union-type-type) (%%typep object union-type-type))
 	   (union-type-types type)))
@@ -127,6 +117,14 @@
      (and (consp object)
 	  (%%typep (car object) (cons-type-car-type type))
 	  (%%typep (cdr object) (cons-type-cdr-type type))))
+    (character-set-type
+     (and (characterp object)
+         (let ((code (char-code object))
+               (pairs (character-set-type-pairs type)))
+           (dolist (pair pairs nil)
+             (destructuring-bind (low . high) pair
+               (when (<= low code high)
+                 (return t)))))))
     (unknown-type
      ;; dunno how to do this ANSIly -- WHN 19990413
      #+sb-xc-host (error "stub: %%TYPEP UNKNOWN-TYPE in xcompilation host")
@@ -136,6 +134,8 @@
 	   (error "unknown type specifier: ~S"
 		  (unknown-type-specifier reparse))
 	   (%%typep object reparse))))
+    (negation-type
+     (not (%%typep object (negation-type-type type))))
     (hairy-type
      ;; Now the tricky stuff.
      (let* ((hairy-spec (hairy-type-specifier type))
@@ -158,37 +158,37 @@
 	  (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 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)))
-    (unless class
-      (error "The class ~S has not yet been defined." (class-cell-name cell)))
-    (class-typep obj-layout class object)))
+(defun classoid-cell-typep (obj-layout cell object)
+  (let ((classoid (classoid-cell-classoid cell)))
+    (unless classoid
+      (error "The class ~S has not yet been defined."
+	     (classoid-cell-name cell)))
+    (classoid-typep obj-layout classoid object)))
 
-;;; Test whether OBJ-LAYOUT is from an instance of CLASS.
-(defun class-typep (obj-layout class object)
+;;; Test whether OBJ-LAYOUT is from an instance of CLASSOID.
+(defun classoid-typep (obj-layout classoid 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))
+    (if (and (typep (classoid-of object) 'standard-classoid) 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))
+	       (classoid-proper-name (layout-classoid obj-layout)))))
+  (let ((layout (classoid-layout classoid))
 	(obj-inherits (layout-inherits obj-layout)))
     (when (layout-invalid layout)
-      (error "The class ~S is currently invalid." class))
+      (error "The class ~S is currently invalid." classoid))
     (or (eq obj-layout layout)
 	(dotimes (i (length obj-inherits) nil)
 	  (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)