blob: 69b877233681f8dc5645cfb8890b71d63a5257e8 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
|
;;; Solutions copyright (C) 2007, Peter Danenberg; http://wizardbook.org
;;; Source code copyright (C) 1996, MIT; http://mitpress.mit.edu/sicp
(load "make-non-blocking-mutex.scm")
;; May be cheating in the sense that make-non-blocking-mutex is a thin
;; wrapper around test-and-set!.
(define (make-mutex-semaphore n)
(define (make-mutices n)
(let make-mutices ((i 0)
(mutices '()))
(if (< i n)
(make-mutices (1+ i) (cons (make-non-blocking-mutex) mutices))
mutices)))
(let ((mutices (make-mutices n)))
(define (acquire)
(let ((acquirendum
(find-matching-item mutices
(lambda (mutex) (false? (mutex 'acquire))))))
(if (not acquirendum) (acquire))))
(define (release)
(let ((relaxandum
(find-matching-item mutices
(lambda (mutex) (mutex 'release)))))
(if relaxandum
(relaxandum 'release)
(error "No acquired mutices -- RELEASE" mutices))))
(define (dispatch m)
(cond ((eq? m 'acquire) (acquire))
((eq? m 'release) (release))
(else (error "Unknown request" m))))
dispatch))
|
