Add implementation of exercise 3-47

Author: ramsayleung

README.org

@@ -25,7 +25,7 @@
   习题完成情况:
   - 章节一: 43/46
   - 章节二: 88/97
-  - 章节三: 46/82
+  - 章节三: 47/82
   - 章节四: TODO
   - 章节五: TODO
 * 运行

chapter3/exercise3-47.rkt

@@ -0,0 +1,69 @@
+#lang racket
+
+(require "mutex.rkt")
+
+(define (make-semaphore n)
+  (let ((count n)
+        (mutex (make-mutex)))
+    (define (acquire)
+      (let loop ()
+        (mutex 'acquire)
+        (if (> count 0)
+            (begin
+              (set! count (- count 1))
+              (mutex 'release))
+            (begin
+              (mutex 'release)
+              (sleep 0.01)
+              (loop)))))
+
+    (define (release)
+      (mutex 'acquire)
+      (set (count (+ count  1)))
+      (mutex 'release))
+
+    (lambda (m)
+      (cond ((eq? m 'acquire) acquire)
+            ((eq? m 'release) release)
+            (else (error "Unknown operation " m))))))
+
+(module+ test
+  (require rackunit)
+
+  (test-case "Basic semaphore operations"
+             (define sem (make-semaphore 2))
+
+             (check-not-exn (lambda () (sem 'acquire)))
+             (check-not-exn (lambda () (sem 'acquire)))
+
+             (check-not-exn (lambda () (sem 'release))))
+
+  (test-case "Threading test"
+             (define sem (make-semaphore 1))
+             (define results '())
+             (define result-mutex (make-mutex))
+
+             (define (add-result x)
+               (result-mutex 'acquire)
+               (set! results (cons x results))
+               (result-mutex 'release))
+
+             (sem 'acquire)
+
+             (thread (lambda ()
+                       (sleep 0.05)
+                       (add-result 'thread-started)
+                       (sem 'acquire)
+                       (add-result 'thread-acquired)
+                       (sem 'release)))
+
+             (add-result 'main-holding)
+             (add-result 'main-releasing)
+             (sem 'release)
+
+             ;; Give thread time to complete
+             (sleep 0.2)
+             (check-equal? (car results) 'thread-acquired)
+             (check-equal? (car (cdr results))  'thread-started)
+             )
+  )

chapter3/mutex.rkt

@@ -0,0 +1,20 @@
+#lang racket
+(define (test-and-set! cell)
+  ;; box-cas! is atomic operation
+  (not (box-cas! cell #f #t)))
+
+(define (make-mutex)
+  (let ((cell (box #f)))
+    (define (the-mutex m)
+      (cond ((eq? m 'acquire)
+             (when (test-and-set! cell)
+               ;; retry
+               (the-mutex 'acquire)))
+            ((eq? m 'release)
+             (clear! cell))))
+    the-mutex))
+
+(define (clear! cell)
+  (box-cas! cell #t #f))
+
+(provide make-mutex)