Update mvars module.

There were some issues with the original version that Mark Weaver has
fixed.

This also resolves an issue where mvars was unusable on Guile versions
less than 2.0.9 because of a docstring on case-lambda.

2 files changed, 88 insertions, 89 deletions

diff --git a/2d/mvars.scm b/2d/mvars.scm
index 70674a4..77461ae 100644
--- a/2d/mvars.scm
+++ b/2d/mvars.scm
@@ -20,118 +20,104 @@
 ;;; Code:
 
 (define-module (2d mvars)
-  #:use-module (srfi srfi-8)     ; receive
-  #:use-module (srfi srfi-9)     ; records
-  #:use-module (srfi srfi-9 gnu)
   #:use-module (ice-9 threads)
-  #:export (new-mvar mvar? mvar-empty?
-                     take-mvar put-mvar read-mvar swap-mvar
-                     try-take-mvar try-put-mvar try-read-mvar
-                     with-mvar modify-mvar modify-mvar*))
+  #:use-module (srfi srfi-8)            ; receive
+  #:use-module (srfi srfi-9)            ; records
+  #:use-module (srfi srfi-9 gnu)
+  #:export (mvar?
+            mvar-empty? new-empty-mvar new-mvar
+            take-mvar put-mvar read-mvar swap-mvar
+            try-take-mvar try-put-mvar
+            with-mvar modify-mvar modify-mvar*))
 
 (define-record-type <mvar>
-  (make-mvar contents empty? mutex condvar)
+  (make-mvar contents empty? mutex full-condition empty-condition)
   mvar?
-  (contents mvar-contents set-mvar-contents!)
-  (empty? mvar-empty? set-mvar-empty?!)
-  (mutex mvar-mutex)
-  (condvar mvar-condvar))
+  (contents         %mvar-contents   %set-mvar-contents!)
+  (empty?           %mvar-empty?     %set-mvar-empty?!)
+  (mutex            mvar-mutex)
+  (full-condition   mvar-full-condition)
+  (empty-condition  mvar-empty-condition))
 
-(set-record-type-printer!
- <mvar>
- (lambda (mvar port)
-   (display "#<mvar " port)
-   (display (number->string (object-address mvar) 16) port)
-   (display " " port)
-   (write (receive (x full?) (try-read-mvar mvar)
-            (if full? (list x) '()))
-          port)
-   (display ">" port)))
-
-(define new-mvar
-  (case-lambda
-    "Return a freshly allocated mvar.  The optional argument, if provided,\n\
-specifies the initial contents of the mvar, otherwise it will be empty."
-    (()  (make-mvar #f #t (make-mutex) (make-condition-variable)))
-    ((x) (make-mvar x  #f (make-mutex) (make-condition-variable)))))
+(define (mvar-empty? mvar)
+  (with-mutex (mvar-mutex mvar)
+    (%mvar-empty? mvar)))
+
+(define (new-empty-mvar)
+  "Return a freshly allocated mvar that is initially empty."
+  (make-mvar #f  ; contents
+             #t  ; empty?
+             (make-mutex)
+             (make-condition-variable)
+             (make-condition-variable)))
+
+(define (new-mvar x)
+  "Return a freshly allocated mvar with initial contents X."
+  (make-mvar x   ; contents
+             #f  ; empty?
+             (make-mutex)
+             (make-condition-variable)
+             (make-condition-variable)))
 
 (define (take-mvar mvar)
   "Block until MVAR is full, then atomically remove and return its contents."
   (with-mutex (mvar-mutex mvar)
-    (when (mvar-empty? mvar)
-      (wait-condition-variable (mvar-condvar mvar) (mvar-mutex mvar))
-      (when (mvar-empty? mvar)
-        (error "take-mvar: expected full mvar after waiting")))
-    (let ((x (mvar-contents mvar)))
-      (set-mvar-contents! mvar #f)
-      (set-mvar-empty?! mvar #t)
-      (signal-condition-variable (mvar-condvar mvar))
+    (when (%mvar-empty? mvar)
+      (wait-condition-variable (mvar-full-condition mvar) (mvar-mutex mvar)))
+    (let ((x (%mvar-contents mvar)))
+      (%set-mvar-contents! mvar #f)
+      (%set-mvar-empty?! mvar #t)
+      (signal-condition-variable (mvar-empty-condition mvar))
       x)))
 
 (define (put-mvar mvar x)
   "Block until MVAR is empty, then put X into it."
   (with-mutex (mvar-mutex mvar)
-    (unless (mvar-empty? mvar)
-      (wait-condition-variable (mvar-condvar mvar) (mvar-mutex mvar))
-      (unless (mvar-empty? mvar)
-        (error "put-mvar: expected empty mvar after waiting")))
-    (set-mvar-contents! mvar x)
-    (set-mvar-empty?! mvar #f)
-    (signal-condition-variable (mvar-condvar mvar))
+    (unless (%mvar-empty? mvar)
+      (wait-condition-variable (mvar-empty-condition mvar) (mvar-mutex mvar)))
+    (%set-mvar-contents! mvar x)
+    (%set-mvar-empty?! mvar #f)
+    (signal-condition-variable (mvar-full-condition mvar))
     *unspecified*))
 
 (define (read-mvar mvar)
-  "Block until MVAR is full, then return its contents, leaving MVAR unchanged."
-  (with-mutex (mvar-mutex mvar)
-    (when (mvar-empty? mvar)
-      (wait-condition-variable (mvar-condvar mvar) (mvar-mutex mvar))
-      (when (mvar-empty? mvar)
-        (error "read-mvar: expected full mvar after waiting")))
-    (mvar-contents mvar)))
-
-(define (swap-mvar mvar new)
-  "Block until MVAR is full, and then atomically swap its contents\n\
-with NEW and return the previous contents."
-  (with-mutex (mvar-mutex mvar)
-    (when (mvar-empty? mvar)
-      (wait-condition-variable (mvar-condvar mvar) (mvar-mutex mvar))
-      (when (mvar-empty? mvar)
-        (error "swap-mvar: expected full mvar after waiting")))
-    (let ((old (mvar-contents mvar)))
-      (set-mvar-contents! mvar new)
-      old)))
+  "Take a value x from MVAR, then put it back and return x.  This
+procedure is atomic only if there are no other producers for MVAR."
+  (let ((x (take-mvar mvar)))
+    (put-mvar mvar x)
+    x))
+
+(define (swap-mvar mvar y)
+  "Take a value x from MVAR, then put Y into MVAR and return x.  This
+procedure is atomic only if there are no other producers for MVAR."
+  (let ((x (take-mvar mvar)))
+    (put-mvar mvar y)
+    x))
 
 (define (try-take-mvar mvar)
   "If MVAR is full, return its contents and #t, else return #f and #f."
   (with-mutex (mvar-mutex mvar)
-    (if (mvar-empty? mvar)
+    (if (%mvar-empty? mvar)
         (values #f #f)
-        (let ((x (mvar-contents mvar)))
-          (set-mvar-contents! mvar #f)
-          (set-mvar-empty?! mvar #t)
-          (signal-condition-variable (mvar-condvar mvar))
+        (let ((x (%mvar-contents mvar)))
+          (%set-mvar-contents! mvar #f)
+          (%set-mvar-empty?! mvar #t)
+          (signal-condition-variable (mvar-empty-condition mvar))
           (values x #t)))))
 
 (define (try-put-mvar mvar x)
   "If MVAR is empty, put X into it and return #t, else return #f."
   (with-mutex (mvar-mutex mvar)
-    (and (mvar-empty? mvar)
+    (and (%mvar-empty? mvar)
          (begin
-           (set-mvar-contents! mvar x)
-           (set-mvar-empty?! mvar #f)
-           (signal-condition-variable (mvar-condvar mvar))
+           (%set-mvar-contents! mvar x)
+           (%set-mvar-empty?! mvar #f)
+           (signal-condition-variable (mvar-full-condition mvar))
            #t))))
 
-(define (try-read-mvar mvar)
-  "If MVAR is full, return its contents and #t, else return #f and #f."
-  (with-mutex (mvar-mutex mvar)
-    (if (mvar-empty? mvar)
-        (values #f #f)
-        (values (mvar-contents mvar) #t))))
-
 (define (with-mvar mvar proc)
-  "Take a value from MVAR and apply PROC to it.  If an exception is raised,\n\
-the original value is put back into MVAR.  This procedure is atomic only if\n\
+  "Take a value from MVAR and apply PROC to it.  If an exception is raised,
+the original value is put back into MVAR.  This procedure is atomic only if
 there are no other producers for MVAR."
   (let ((x (take-mvar mvar)))
     (catch #t
@@ -141,8 +127,8 @@ there are no other producers for MVAR."
         (apply throw key args)))))
 
 (define (modify-mvar mvar f)
-  "Take a value x from MVAR, and then put back (F x).  If an exception is\n\
-raised, the original value is put back into MVAR.  This procedure is\n\
+  "Take a value x from MVAR, and then put back (F x).  If an exception is
+raised, the original value is put back into MVAR.  This procedure is
 atomic only if there are no other producers for MVAR."
   (let ((old (take-mvar mvar)))
     (catch #t
@@ -152,10 +138,10 @@ atomic only if there are no other producers for MVAR."
         (apply throw key args)))))
 
 (define (modify-mvar* mvar f)
-  "Take a value x from MVAR, and apply F to it.  (F x) should return one\n\
-or more values: the new value to be put back into MVAR, and zero or more\n\
-additional values to be returned from MODIFY-MVAR*.  If an exception is\n\
-raised, the original value is put back into MVAR.  This procedure is\n\
+  "Take a value x from MVAR, and apply F to it.  (F x) should return one
+or more values: the new value to be put back into MVAR, and zero or more
+additional values to be returned from MODIFY-MVAR*.  If an exception is
+raised, the original value is put back into MVAR.  This procedure is
 atomic only if there are no other producers for MVAR."
   (let ((old (take-mvar mvar)))
     (catch #t
@@ -166,3 +152,16 @@ atomic only if there are no other producers for MVAR."
       (lambda (key . args)
         (put-mvar mvar old)
         (apply throw key args)))))
+
+(set-record-type-printer!
+ <mvar>
+ (lambda (mvar port)
+   (display "#<mvar " port)
+   (display (number->string (object-address mvar) 16) port)
+   (display " " port)
+   (write (with-mutex (mvar-mutex mvar)
+            (if (%mvar-empty? mvar)
+                '()
+                (list (%mvar-contents mvar))))
+          port)
+   (display ">" port)))
diff --git a/2d/repl/repl.scm b/2d/repl/repl.scm
index 253789d..4ff8f52 100644
--- a/2d/repl/repl.scm
+++ b/2d/repl/repl.scm
@@ -130,8 +130,8 @@
 ;;; The repl
 ;;;
 
-(define repl-input-mvar (new-mvar))
-(define repl-output-mvar (new-mvar))
+(define repl-input-mvar  (new-empty-mvar))
+(define repl-output-mvar (new-empty-mvar))
 
 (define* (start-repl #:optional (lang (current-language)) #:key debug)
   ;; ,language at the REPL will update the current-language.  Make