1.0.16.46: small fixes to tests

[sbcl.git] / tests / threads.pure.lisp

diff --git a/tests/threads.pure.lisp b/tests/threads.pure.lisp
index f078b5b..b10820a 100644 (file)
--- a/tests/threads.pure.lisp
+++ b/tests/threads.pure.lisp
@@ -50,3 +50,37 @@
     (condition-notify queue)
     (sleep 1)
     (assert (not (thread-alive-p thread)))))
+
+;;; GET-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
+
+#+sb-thread
+(with-test (:name without-interrupts+get-mutex)
+  (let* ((lock (make-mutex))
+         (bar (progn (get-mutex lock) nil))
+         (thread (make-thread (lambda ()
+                                (sb-sys:without-interrupts
+                                    (with-mutex (lock)
+                                      (setf bar t)))))))
+    (sleep 1)
+    (assert (thread-alive-p thread))
+    (terminate-thread thread)
+    (sleep 1)
+    (assert (thread-alive-p thread))
+    (release-mutex lock)
+    (sleep 1)
+    (assert (not (thread-alive-p thread)))
+    (assert (eq :aborted (join-thread thread :default :aborted)))
+    (assert bar)))
+
+#+sb-thread
+(with-test (:name parallel-find-class)
+  (let* ((oops nil)
+         (threads (loop repeat 10
+                        collect (make-thread (lambda ()
+                                               (handler-case
+                                                   (loop repeat 10000
+                                                         do (find-class (gensym) nil))
+                                                 (serious-condition ()
+                                                   (setf oops t))))))))
+    (mapcar #'sb-thread:join-thread threads)
+    (assert (not oops))))