X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftypep.lisp;h=43acfdfdb561b0d6a83105885897ecf2b9f4e4de;hb=a160917364f85b38dc0826a5e3dcef87e3c4c62c;hp=0844ebf06af7c08fed2d98a9010edf3d3e3344a2;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git

diff --git a/src/code/typep.lisp b/src/code/typep.lisp
index 0844ebf..43acfdf 100644
--- a/src/code/typep.lisp
+++ b/src/code/typep.lisp
@@ -37,6 +37,9 @@
     (named-type
      (ecase (named-type-name type)
        ((* t) t)
+       ((instance) (%instancep object))
+       ((funcallable-instance) (funcallable-instance-p object))
+       ((extended-sequence) (extended-sequence-p object))
        ((nil) nil)))
     (numeric-type
      (and (numberp object)
@@ -102,7 +105,8 @@
                              (specifier-type (array-element-type
                                               object)))))))
     (member-type
-     (if (member object (member-type-members type)) t))
+     (when (member-type-member-p object type)
+       t))
     (classoid
      #+sb-xc-host (ctypep object type)
      #-sb-xc-host (classoid-typep (layout-of object) type object))
@@ -174,21 +178,27 @@
 ;;; 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 (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)."
-               (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." classoid))
-    (or (eq obj-layout layout)
-        (dotimes (i (length obj-inherits) nil)
-          (when (eq (svref obj-inherits i) layout)
-            (return t))))))
-
-;;; 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)
+  ;; FIXME & KLUDGE: We could like to grab the *WORLD-LOCK* here (to ensure that
+  ;; class graph doesn't change while we're doing the typep test), but in
+  ;; pratice that causes trouble -- deadlocking against the compiler
+  ;; if compiler output (or macro, or compiler-macro expansion) causes
+  ;; another thread to do stuff. Not locking is a shoddy bandaid as it is remains
+  ;; easy to trigger the same problem using a different code path -- but in practice
+  ;; locking here makes Slime unusable with :SPAWN in post *WORLD-LOCK* world. So...
+  ;; -- NS 2008-12-16
+  (multiple-value-bind (obj-layout layout)
+      (do ((layout (classoid-layout classoid) (classoid-layout classoid))
+           (i 0 (+ i 1))
+           (obj-layout obj-layout))
+          ((and (not (layout-invalid obj-layout))
+                (not (layout-invalid layout)))
+           (values obj-layout layout))
+        (aver (< i 2))
+        (when (layout-invalid obj-layout)
+          (setq obj-layout (update-object-layout-or-invalid object layout)))
+        (%ensure-classoid-valid classoid layout))
+    (let ((obj-inherits (layout-inherits obj-layout)))
+      (or (eq obj-layout layout)
+          (dotimes (i (length obj-inherits) nil)
+            (when (eq (svref obj-inherits i) layout)
+              (return t)))))))