SICP/ex-3_46-xx.scm

(load "util.scm")

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

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