1.0.33.22: fix WITH-MUTEX docstring

[sbcl.git] / contrib / sb-introspect / test-driver.lisp

diff --git a/contrib/sb-introspect/test-driver.lisp b/contrib/sb-introspect/test-driver.lisp
index 322ca91..f482b8d 100644 (file)
--- a/contrib/sb-introspect/test-driver.lisp
+++ b/contrib/sb-introspect/test-driver.lisp
@@ -238,23 +238,40 @@
   nil)
 
 (deftest deftype-lambda-list.1
-    (multiple-value-bind (arglist found?) (deftype-lambda-list 'foobar-type)
-          (and found?
-               (equal arglist '(&whole w &environment e
-                                r1 r2 &optional o &rest rest &key k1 k2 k3))))
+    (deftype-lambda-list 'foobar-type)
+  (&whole w &environment e r1 r2 &optional o &rest rest &key k1 k2 k3)
   t)
 
 (deftest deftype-lambda-list.2
-    (equal (multiple-value-list (deftype-lambda-list (gensym)))
-           '(nil nil))
+    (deftype-lambda-list (gensym))
+  nil
+  nil)
+
+;; ARRAY is a primitive type with associated translator function.
+(deftest deftype-lambda-list.3
+    (deftype-lambda-list 'array)
+  (&optional (sb-kernel::element-type '*) (sb-kernel::dimensions '*))
+  t)
+
+;; VECTOR is a primitive type that is defined by means of DEFTYPE.
+(deftest deftype-lambda-list.4
+    (deftype-lambda-list 'vector)
+  (&optional sb-kernel::element-type sb-kernel::size)
   t)
 
 ;;; Test allocation-information
 
-(defun tai (x kind info)
+(defun tai (x kind info &key ignore)
   (multiple-value-bind (kind2 info2) (sb-introspect:allocation-information x)
     (unless (eq kind kind2)
       (error "wanted ~S, got ~S" kind kind2))
+    (when (not (null ignore))
+      (setf info2 (copy-list info2))
+      (dolist (key ignore)
+        (remf info2 key))
+      (setf info (copy-list info))
+      (dolist (key ignore)
+        (remf info key)))
     (equal info info2)))
 
 (deftest allocation-infromation.1
@@ -270,21 +287,18 @@
   t)
 
 (deftest allocation-information.4
+    #+gencgc
     (tai #'cons :heap
-         #+(and (not ppc) gencgc)
-         ;; FIXME: This is the canonical GENCGC result, the one below for PPC is
-         ;; what we get there, but :LARGE T doesn't seem right. Figure out what's
-         ;; going on.
-         '(:space :dynamic :generation 6 :write-protected t :pinned nil :large nil)
-         #+(and ppc gencgc)
-         '(:space :dynamic :generation 6 :write-protected t :pinned nil :large t)
-         ;; FIXME: Figure out what's the right cheney-result, and which platforms
-         ;; return something else. The SPARC version here is what we get there,
-         ;; but quite possibly that is the result on all non-GENCGC platforms.
-         #+(and sparc (not gencgc))
-         '(:space :read-only)
-         #+(and (not sparc) (not gencgc))
-         '(:space :dynamic))
+         ;; FIXME: This is the canonical GENCGC result. On PPC we sometimes get
+         ;; :LARGE T, which doesn't seem right -- but ignore that for now.
+         '(:space :dynamic :generation 6 :write-protected t :boxed t :pinned nil :large nil)
+         :ignore #+ppc '(:large) #-ppc nil)
+    #-gencgc
+    (tai :cons :heap
+         ;; FIXME: Figure out what's the right cheney-result. SPARC at least
+         ;; has exhibited both :READ-ONLY and :DYNAMIC, which seems wrong.
+         '()
+         :ignore '(:space))
   t)
 
 #+sb-thread
@@ -320,12 +334,12 @@
                         (sb-thread:wait-on-semaphore sem)))
                     :name "child")))
        (loop until obj)
-       (assert (equal (list :stack child)
-                      (multiple-value-list
-                       (sb-introspect:allocation-information obj))))
-       (sb-thread:signal-semaphore sem)
-       (sb-thread:join-thread child)
-       nil))
+       (unwind-protect
+            (equal (list :stack child)
+                   (multiple-value-list
+                    (sb-introspect:allocation-information obj)))
+         (sb-thread:signal-semaphore sem)
+         (sb-thread:join-thread child))))
 
    (deftest allocation-information.thread.3
        (thread-tai2)