Implement 3.47
parent
dce7ffebf9
commit
3762a87235
166
ex-3_46-xx.scm
166
ex-3_46-xx.scm
|
@ -1,8 +1,170 @@
|
|||
(load "util.scm")
|
||||
|
||||
(display "\nex-3.46\n")
|
||||
(define (make-serializer)
|
||||
(let ((mutex (make-mutex)))
|
||||
(lambda (p)
|
||||
(define (serialized-p . args)
|
||||
(mutex 'acquire)
|
||||
(let ((val (apply p args)))
|
||||
(mutex 'release)
|
||||
val))
|
||||
serialized-p)))
|
||||
|
||||
(display "\nex-3.47\n")
|
||||
(define (make-mutex)
|
||||
(let ((cell (list false)))
|
||||
(define (the-mutex m)
|
||||
(cond ((eq? m 'acquire)
|
||||
(if (test-and-set! cell)
|
||||
(the-mutex 'acquire))) ; retry
|
||||
((eq? m 'release) (clear! cell))))
|
||||
the-mutex))
|
||||
|
||||
(define (clear! cell)
|
||||
(set-car! cell false))
|
||||
|
||||
(define (test-and-set! cell)
|
||||
(without-interrupts
|
||||
(lambda ()
|
||||
(if (car cell)
|
||||
true
|
||||
(begin (set-car! cell true)
|
||||
false)))))
|
||||
|
||||
(display "\nex-3.46\n")
|
||||
(display "[answered]\n")
|
||||
; See page 207 in 2020 BuJo.
|
||||
|
||||
(display "\nex-3.47 - semaphore\n")
|
||||
|
||||
(define (make-semaphore max-count)
|
||||
(if (< max-count 1)
|
||||
(error "semaphore count must be at least 1")
|
||||
(let ((mutex-acquire (make-mutex))
|
||||
(mutex-release (make-mutex))
|
||||
(count 0))
|
||||
(define (acquire)
|
||||
(mutex-acquire 'acquire)
|
||||
(if (< count max-count)
|
||||
(begin
|
||||
(mutex-release 'acquire)
|
||||
(set! count (+ count 1))
|
||||
(mutex-release 'release)
|
||||
(mutex-acquire 'release)
|
||||
'ok)
|
||||
(begin
|
||||
(mutex-acquire 'release)
|
||||
(acquire))))
|
||||
(define (release)
|
||||
(mutex-release 'acquire)
|
||||
(set! count (- count 1))
|
||||
(mutex-release 'release))
|
||||
(define (the-semaphore s)
|
||||
(cond
|
||||
((eq? s 'acquire) (acquire))
|
||||
((eq? s 'release) (release))
|
||||
((eq? s 'count) count)
|
||||
((eq? s 'remaining) (- max-count count))
|
||||
(else "operation not supported" s)))
|
||||
the-semaphore)))
|
||||
|
||||
(define s (make-semaphore 3))
|
||||
(assert (s 'count) 0)
|
||||
(s 'acquire)
|
||||
(s 'acquire)
|
||||
(s 'acquire)
|
||||
(assert (s 'remaining) 0)
|
||||
(s 'release)
|
||||
(s 'acquire)
|
||||
(s 'release)
|
||||
(s 'release)
|
||||
(s 'release)
|
||||
(assert (s 'remaining) 3)
|
||||
|
||||
(define (make-semaphore max-count)
|
||||
(if (< max-count 1)
|
||||
(error "semaphore count must be at least 1")
|
||||
(let ((cell (list #f))
|
||||
(count 0))
|
||||
(define (acquire)
|
||||
(if (test-and-set! cell)
|
||||
(acquire)
|
||||
(if (< count max-count)
|
||||
(begin
|
||||
(set! count (+ count 1))
|
||||
(clear! cell)
|
||||
'ok)
|
||||
(begin
|
||||
(clear! cell)
|
||||
(acquire)))))
|
||||
(define (release)
|
||||
(if (test-and-set! cell)
|
||||
(release)
|
||||
(begin
|
||||
(set! count (- count 1))
|
||||
(clear! cell))))
|
||||
(define (the-semaphore s)
|
||||
(cond
|
||||
((eq? s 'acquire) (acquire))
|
||||
((eq? s 'release) (release))
|
||||
((eq? s 'count) count)
|
||||
((eq? s 'remaining) (- max-count count))
|
||||
(else "operation not supported" s)))
|
||||
the-semaphore)))
|
||||
|
||||
(define s (make-semaphore 3))
|
||||
(assert (s 'count) 0)
|
||||
(s 'acquire)
|
||||
(s 'acquire)
|
||||
(s 'acquire)
|
||||
(assert (s 'remaining) 0)
|
||||
(s 'release)
|
||||
(s 'acquire)
|
||||
(s 'release)
|
||||
(s 'release)
|
||||
(s 'release)
|
||||
(assert (s 'remaining) 3)
|
||||
|
||||
(display "\nex-3.48\n")
|
||||
|
||||
(define (make-account-and-serializer balance)
|
||||
(define (withdraw amount)
|
||||
(if (>= balance amount)
|
||||
(begin (set! balance (- balance amount))
|
||||
balance)
|
||||
"Insufficient funds"))
|
||||
(define (deposit amount)
|
||||
(set! balance (+ balance amount))
|
||||
balance)
|
||||
(let ((balance-serializer (make-serializer)))
|
||||
(define (dispatch m)
|
||||
(cond ((eq? m 'withdraw) withdraw)
|
||||
((eq? m 'deposit) deposit)
|
||||
((eq? m 'balance) balance)
|
||||
((eq? m 'serializer) balance-serializer)
|
||||
(else (error "Unknown request -- MAKE-ACCOUNT"
|
||||
m))))
|
||||
dispatch))
|
||||
|
||||
(define (deposit account amount)
|
||||
(let ((s (account 'serializer))
|
||||
(d (account 'deposit)))
|
||||
((s d) amount)))
|
||||
|
||||
(define (exchange account1 account2)
|
||||
(let ((difference (- (account1 'balance)
|
||||
(account2 'balance))))
|
||||
((account1 'withdraw) difference)
|
||||
((account2 'deposit) difference)))
|
||||
|
||||
(define (serialized-exchange account1 account2)
|
||||
(let ((serializer1 (account1 'serializer))
|
||||
(serializer2 (account2 'serializer)))
|
||||
((serializer1 (serializer2 exchange))
|
||||
account1
|
||||
account2)))
|
||||
|
||||
(define a (make-account-and-serializer 100))
|
||||
(define b (make-account-and-serializer 40))
|
||||
(serialized-exchange a b)
|
||||
(assert (a 'balance) 40)
|
||||
|
||||
|
|
Loading…
Reference in New Issue