1.1--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2+++ b/lisp/std/tests/thread.lisp	Thu Oct 03 17:56:11 2024 -0400
     1.3@@ -0,0 +1,74 @@
     1.4+;;; thread.lisp --- Thread Tests
     1.5+
     1.6+;; 
     1.7+
     1.8+;;; Code:
     1.9+(in-package :std/tests)
    1.10+(in-suite :std)
    1.11+
    1.12+(deftest with-threads ()
    1.13+  "Test with-threads macro."
    1.14+  (with-threads (4 :args (&optional (a 0) (b 1) (c 2)))
    1.15+    (is (= 3 (+ a b c)))))
    1.16+
    1.17+(deftest threads ()
    1.18+  "Test standard thread functionality."
    1.19+  (is (eq *current-thread*
    1.20+          (find (thread-name *current-thread*) (list-all-threads)
    1.21+                :key #'thread-name :test #'equal)))
    1.22+  (is (find-thread-by-id (car (thread-id-list))))
    1.23+  (is (not (zerop (thread-count))))
    1.24+  (let ((threads
    1.25+          (make-threads 4 (lambda () (is (= 42 (1+ 41)))) :name "threads")))
    1.26+    (loop for th in threads
    1.27+          do (sb-thread:join-thread th))
    1.28+    (loop for th in threads
    1.29+          collect (is (not (sb-thread:thread-alive-p th)))))
    1.30+  (let ((m (make-mutex :name "mutex-test")))
    1.31+    (is
    1.32+     (and (not
    1.33+           (with-mutex (m)
    1.34+             (join-thread
    1.35+              (make-thread (lambda ()
    1.36+                             (with-mutex (m :timeout 0.1)
    1.37+                               t))))))
    1.38+          (join-thread
    1.39+           (make-thread (lambda ()
    1.40+                          (with-mutex (m :timeout 0.1)
    1.41+                            t)))))))
    1.42+  (let* ((sym (gensym))
    1.43+         (s (make-semaphore :name "semaphore-test"))
    1.44+         (th (make-thread (lambda () (wait-on-semaphore s)))))
    1.45+    (is (equal (multiple-value-list (join-thread th :timeout .001 :default sym))
    1.46+               (list sym :timeout)))
    1.47+    (signal-semaphore s)
    1.48+    (is (join-thread th)))
    1.49+  (signals join-thread-error (join-thread *current-thread*))
    1.50+  (is
    1.51+   (let ((m (make-mutex :name "rlock-test")))
    1.52+     (is (not (with-mutex (m) (join-thread (make-thread (lambda () (with-recursive-lock (m :wait-p nil) t)))))))
    1.53+     (join-thread (make-thread (lambda () (with-recursive-lock (m :wait-p nil) t))))))
    1.54+  (let ((queue (make-waitqueue :name "queue-test"))
    1.55+        (lock (make-mutex :name "lock-test"))
    1.56+        (n 0)
    1.57+        th)
    1.58+    (labels ((in-new-thread ()
    1.59+               (with-mutex (lock)
    1.60+                 (assert (eql (mutex-owner lock) *current-thread*))
    1.61+                 (condition-wait queue lock)
    1.62+                 (assert (eql (mutex-owner lock) *current-thread*))
    1.63+                 (is (= n 1))
    1.64+                 (decf n))))
    1.65+      (setf th (make-thread #'in-new-thread))
    1.66+      (sleep 1)
    1.67+      (is (null (mutex-owner lock)))
    1.68+      (with-mutex (lock)
    1.69+        (incf n)
    1.70+        (condition-notify queue))
    1.71+      (is (= 0 (join-thread th))))))
    1.72+
    1.73+(deftest timers ()
    1.74+  "Test various timer functionality."
    1.75+  (sb-int:with-progressive-timeout (ttl :seconds 2)
    1.76+    (sleep 0.1)
    1.77+    (is (/= (ttl) 2.0))))