Implement 3.47

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)
+