1 665c255d 2023-08-04 jrmu (define (make-semaphore-mtx maximal)
 2 665c255d 2023-08-04 jrmu   (let ((count maximal)
 3 665c255d 2023-08-04 jrmu 	(mutex (make-mutex)))
 4 665c255d 2023-08-04 jrmu     (define (the-sema m)
 5 665c255d 2023-08-04 jrmu       (cond ((eq? m 'release)
 6 665c255d 2023-08-04 jrmu 	     (mutex 'acquire)
 7 665c255d 2023-08-04 jrmu 	     (unless (= count maximal)
 8 665c255d 2023-08-04 jrmu 	       (set! count (+ 1 count)))
 9 665c255d 2023-08-04 jrmu 	     (mutex 'release))
10 665c255d 2023-08-04 jrmu 	    ((eq? m 'acquire)
11 665c255d 2023-08-04 jrmu 	     (mutex 'acquire)
12 665c255d 2023-08-04 jrmu 	     (cond ((> count 0)
13 665c255d 2023-08-04 jrmu 		    (set! count (- count 1))
14 665c255d 2023-08-04 jrmu 		    (mutex 'release))
15 665c255d 2023-08-04 jrmu 		   (else
16 665c255d 2023-08-04 jrmu 		    (mutex 'release)
17 665c255d 2023-08-04 jrmu 		    (the-sema 'acquire))))
18 665c255d 2023-08-04 jrmu 	    (else 
19 665c255d 2023-08-04 jrmu 	     (error "Unknown request -- " m))))
20 665c255d 2023-08-04 jrmu     the-sema))
21 665c255d 2023-08-04 jrmu 
22 665c255d 2023-08-04 jrmu 
23 665c255d 2023-08-04 jrmu 
24 665c255d 2023-08-04 jrmu (define (loop-test-and-set! cell)
25 665c255d 2023-08-04 jrmu   (if (test-and-set! cell)
26 665c255d 2023-08-04 jrmu       (loop-test-and-set! cell)
27 665c255d 2023-08-04 jrmu       '()))
28 665c255d 2023-08-04 jrmu 
29 665c255d 2023-08-04 jrmu (define (make-semaphore-ts maximal)
30 665c255d 2023-08-04 jrmu   (let ((count maximal)
31 665c255d 2023-08-04 jrmu 	(guard (cons #f '())))
32 665c255d 2023-08-04 jrmu     (define (the-sema m)
33 665c255d 2023-08-04 jrmu       (cond ((eq? m 'release) 
34 665c255d 2023-08-04 jrmu 	     (loop-test-and-set! guard)
35 665c255d 2023-08-04 jrmu 	     (unless (= count maximal)
36 665c255d 2023-08-04 jrmu 	       (set! count (+ 1 count)))
37 665c255d 2023-08-04 jrmu 	     (clear! guard))
38 665c255d 2023-08-04 jrmu 	    ((eq? m 'acquire) 
39 665c255d 2023-08-04 jrmu 	     (cond (loop-test-and-set! guard)
40 665c255d 2023-08-04 jrmu 		   ((> count 0)
41 665c255d 2023-08-04 jrmu 		    (set! count (- count 1))
42 665c255d 2023-08-04 jrmu 		    (clear! guard))
43 665c255d 2023-08-04 jrmu 		   (else
44 665c255d 2023-08-04 jrmu 		    (clear! guard)
45 665c255d 2023-08-04 jrmu 		    (the-sema 'acquire))))
46 665c255d 2023-08-04 jrmu 	    (else
47 665c255d 2023-08-04 jrmu 	     (error "Unknown request -- " m))))
48 665c255d 2023-08-04 jrmu     the-sema))