remove misplaced AVER

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

diff --git a/src/code/typep.lisp b/src/code/typep.lisp
index 2e65f03..374d3bc 100644 (file)
--- a/src/code/typep.lisp
+++ b/src/code/typep.lisp
@@ -31,7 +31,7 @@
            (if (ctype-p specifier)
                specifier
                (specifier-type specifier))))
-(defun %%typep (object type)
+(defun %%typep (object type &optional (strict t))
   (declare (type ctype type))
   (etypecase type
     (named-type
@@ -111,16 +111,22 @@
      #+sb-xc-host (ctypep object type)
      #-sb-xc-host (classoid-typep (layout-of object) type object))
     (union-type
-     (some (lambda (union-type-type) (%%typep object union-type-type))
+     (some (lambda (union-type-type) (%%typep object union-type-type strict))
            (union-type-types type)))
     (intersection-type
      (every (lambda (intersection-type-type)
-              (%%typep object intersection-type-type))
+              (%%typep object intersection-type-type strict))
             (intersection-type-types type)))
     (cons-type
      (and (consp object)
-          (%%typep (car object) (cons-type-car-type type))
-          (%%typep (cdr object) (cons-type-cdr-type type))))
+          (%%typep (car object) (cons-type-car-type type) strict)
+          (%%typep (cdr object) (cons-type-cdr-type type) strict)))
+    #!+sb-simd-pack
+    (simd-pack-type
+     (and (simd-pack-p object)
+          (let* ((tag (%simd-pack-tag object))
+                 (name (nth tag *simd-pack-element-types*)))
+            (not (not (member name (simd-pack-type-element-type type)))))))
     (character-set-type
      (and (characterp object)
          (let ((code (char-code object))
@@ -137,16 +143,16 @@
        (if (typep reparse 'unknown-type)
            (error "unknown type specifier: ~S"
                   (unknown-type-specifier reparse))
-           (%%typep object reparse))))
+           (%%typep object reparse strict))))
     (negation-type
-     (not (%%typep object (negation-type-type type))))
+     (not (%%typep object (negation-type-type type) strict)))
     (hairy-type
      ;; Now the tricky stuff.
      (let* ((hairy-spec (hairy-type-specifier type))
             (symbol (car hairy-spec)))
        (ecase symbol
          (and
-          (every (lambda (spec) (%%typep object (specifier-type spec)))
+          (every (lambda (spec) (%%typep object (specifier-type spec) strict))
                  (rest hairy-spec)))
          ;; Note: it should be safe to skip OR here, because union
          ;; types can always be represented as UNION-TYPE in general
@@ -155,7 +161,7 @@
          (not
           (unless (proper-list-of-length-p hairy-spec 2)
             (error "invalid type specifier: ~S" hairy-spec))
-          (not (%%typep object (specifier-type (cadr hairy-spec)))))
+          (not (%%typep object (specifier-type (cadr hairy-spec)) strict)))
          (satisfies
           (unless (proper-list-of-length-p hairy-spec 2)
             (error "invalid type specifier: ~S" hairy-spec))
@@ -163,8 +169,11 @@
     (alien-type-type
      (sb!alien-internals:alien-typep object (alien-type-type-alien-type type)))
     (fun-type
-     (error "Function types are not a legal argument to TYPEP:~%  ~S"
-            (type-specifier type)))))
+     (if strict
+         (error "Function types are not a legal argument to TYPEP:~%  ~S"
+                (type-specifier type))
+         (and (functionp object)
+              (csubtypep (specifier-type (sb!impl::%fun-type object)) type))))))
 
 ;;; Do a type test from a class cell, allowing forward reference and
 ;;; redefinition.
@@ -178,20 +187,27 @@
 ;;; Test whether OBJ-LAYOUT is from an instance of CLASSOID.
 (defun classoid-typep (obj-layout classoid object)
   (declare (optimize speed))
-  (with-world-lock ()
-    (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))))))))
+  ;; 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 "typep"))
+    (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)))))))