0.pre8.3

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

diff --git a/src/code/typep.lisp b/src/code/typep.lisp
index 19ac49a..2c200f3 100644 (file)
--- a/src/code/typep.lisp
+++ b/src/code/typep.lisp
@@ -13,9 +13,10 @@
 ;;; 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)
+(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
@@ -134,9 +135,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)))
@@ -157,6 +158,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))
@@ -185,31 +188,31 @@
 
 ;;; 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)