Coverage report: /home/ellis/.stash/quicklisp/dists/ultralisp/software/sionescu-bordeaux-threads-20250412101706/apiv2/api-semaphores.lisp

KindCoveredAll%
expression021 0.0
branch00nil
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2 -*-
2
 ;;;; The above modeline is required for Genera. Do not change.
3
 
4
 (in-package :bordeaux-threads-2)
5
 
6
 #-(or abcl allegro ccl ecl lispworks mezzano sbcl)
7
 (defstruct (%semaphore
8
             (:constructor %make-semaphore (name counter)))
9
   name counter
10
   (lock               (make-lock))
11
   (condition-variable (%make-condition-variable nil)))
12
 
13
 #-(or abcl allegro ccl ecl lispworks mezzano sbcl)
14
 (deftype semaphore () '%semaphore)
15
 
16
 (defun make-semaphore (&key name (count 0))
17
   "Create a semaphore with the supplied NAME and initial counter value COUNT."
18
   (check-type name (or null string))
19
   (%make-semaphore name count))
20
 
21
 #-(or abcl allegro ccl ecl lispworks mezzano sbcl)
22
 (defun %signal-semaphore (semaphore count)
23
   (with-lock-held ((%semaphore-lock semaphore))
24
     (incf (%semaphore-counter semaphore) count)
25
     (dotimes (v count)
26
       (%condition-notify (%semaphore-condition-variable semaphore)))))
27
 
28
 (defun signal-semaphore (semaphore &key (count 1))
29
   "Increment SEMAPHORE by COUNT. If there are threads waiting on this
30
 semaphore, then COUNT of them are woken up."
31
   (%signal-semaphore semaphore count)
32
   t)
33
 
34
 #-(or abcl allegro ccl ecl lispworks mezzano sbcl)
35
 (defun %wait-on-semaphore (semaphore timeout)
36
   (with-lock-held ((%semaphore-lock semaphore))
37
     (if (plusp (%semaphore-counter semaphore))
38
         (decf (%semaphore-counter semaphore))
39
         (let ((deadline (when timeout
40
                           (+ (get-internal-real-time)
41
                              (* timeout internal-time-units-per-second)))))
42
           ;; we need this loop because of a spurious wakeup possibility
43
           (loop until (plusp (%semaphore-counter semaphore))
44
                 do (cond
45
                      ((null (%condition-wait
46
                              (%semaphore-condition-variable semaphore)
47
                              (lock-native-lock (%semaphore-lock semaphore))
48
                              timeout))
49
                       (return-from %wait-on-semaphore))
50
                      ;; unfortunately cv-wait may return T on timeout too
51
                      ((and deadline (>= (get-internal-real-time) deadline))
52
                       (return-from %wait-on-semaphore))
53
                      (timeout
54
                       (setf timeout (/ (- deadline (get-internal-real-time))
55
                                        internal-time-units-per-second)))))
56
           (decf (%semaphore-counter semaphore))))
57
     ;; Semaphore acquired.
58
     t))
59
 
60
 #+cmu (mark-not-implemented 'wait-on-semaphore :timeout)
61
 (defun wait-on-semaphore (semaphore &key timeout)
62
   "Decrement the count of SEMAPHORE by 1 if the count is larger than zero.
63
 
64
 If count is zero, blocks until the semaphore can be decremented.
65
 Returns generalized boolean T on success.
66
 
67
 If TIMEOUT is given, it is the maximum number of seconds to wait. If the count
68
 cannot be decremented in that time, returns NIL without decrementing the count."
69
   (%wait-on-semaphore semaphore timeout))
70
 
71
 (defun semaphorep (object)
72
   "Returns T if OBJECT is a semaphore, otherwise NIL."
73
   (typep object 'semaphore))