[Chicken-hackers] [PATCH 5/5] Add new `make-bidirectional-port` procedure to ports unit

[Evan Hanson]

This allows an input and output port to be combined into a single
bidirectional port.
---
 NEWS                 |  3 +++
 library.scm          |  2 +-
 manual/Unit ports    |  9 +++++++++
 ports.scm            | 29 +++++++++++++++++++++++++++++
 tests/port-tests.scm | 33 +++++++++++++++++++++++++++++++++
 types.db             |  1 +
 6 files changed, 76 insertions(+), 1 deletion(-)

diff --git a/NEWS b/NEWS
index 775ee57..9c24d81 100644
--- a/NEWS
+++ b/NEWS
@@ -33,6 +33,9 @@
   - `with-error-output-to-port' from the ports module has been renamed
     to the more common `with-error-to-port', and `with-error-to-string'
     has been added for completeness (thanks to Michael Silver).
+  - A new `make-bidirectional-port' procedure has been added to the
+    ports unit that will combine separate input- and output- ports into
+    a single bidirectional port.
   - New `input-port-open?` and `output-port-open?` procedures have been
     added for testing whether a port is open in a specific direction.
 
diff --git a/library.scm b/library.scm
index be9c61a..c222fd7 100644
--- a/library.scm
+++ b/library.scm
@@ -2772,7 +2772,7 @@ EOF
     (let ((direction (if inp 1 2)))
       (when (##core#inline "C_port_openp" port direction)
        (##sys#setislot port 8 (fxand (##sys#slot port 8) (fxnot direction)))
-       ((##sys#slot (##sys#slot port 2) 4) port inp))))
+       ((##sys#slot (##sys#slot port 2) 4) port direction))))
 
   (set! open-input-file (lambda (name . mode) (open name #t mode 
'open-input-file)))
   (set! open-output-file (lambda (name . mode) (open name #f mode 
'open-output-file)))
diff --git a/manual/Unit ports b/manual/Unit ports
index 9e4d22e..fc8fde4 100644
--- a/manual/Unit ports 
+++ b/manual/Unit ports 
@@ -167,6 +167,15 @@ as {{(READ FROM)}} and {{(WRITE X TO)}}, respectively.
 
 === Funky ports
 
+==== make-bidirectional-port
+
+<procedure>(make-bidirectional-port INPUT-PORT OUTPUT-PORT)</procedure>
+
+Returns a joint input/output port that proxies port operations to the
+given {{INPUT-PORT}} and {{OUTPUT-PORT}}, respectively. This port
+satisfies both {{input-port?}} and {{output-port?}}, and its two
+directions may be closed independently.
+
 ==== make-broadcast-port
 
 <procedure>(make-broadcast-port PORT ...)</procedure>
diff --git a/ports.scm b/ports.scm
index 33390c4..0396423e 100644
--- a/ports.scm
+++ b/ports.scm
@@ -45,6 +45,7 @@
    port-for-each
    port-map
    port-fold
+   make-bidirectional-port
    make-broadcast-port
    make-concatenated-port
    with-error-to-port
@@ -289,4 +290,32 @@
       (##sys#set-port-data! port data) 
       port) ) )
 
+(define (make-bidirectional-port i o)
+  (let* ((class (vector
+                (lambda (_)             ; read-char
+                  (read-char i))
+                (lambda (_)             ; peek-char
+                  (peek-char i))
+                (lambda (_ c)           ; write-char
+                  (write-char c o))
+                (lambda (_ s)           ; write-string
+                  (write-string s #f o))
+                (lambda (_ d)           ; close
+                  (case d
+                    ((1) (close-input-port i))
+                    ((2) (close-output-port o))))
+                (lambda (_)             ; flush-output
+                  (flush-output o))
+                (lambda (_)             ; char-ready?
+                  (char-ready? i))
+                (lambda (_ n d s)       ; read-string!
+                  (read-string! n d i s))
+                (lambda (_ l)           ; read-line
+                  (read-line i l))
+                (lambda ()              ; read-buffered
+                  (read-buffered i))))
+        (port (##sys#make-port 3 class "(bidirectional)" 'bidirectional)))
+    (##sys#set-port-data! port (vector #f))
+    port))
+
 )
diff --git a/tests/port-tests.scm b/tests/port-tests.scm
index 2fc19a0..0f5fdbb 100644
--- a/tests/port-tests.scm
+++ b/tests/port-tests.scm
@@ -131,6 +131,39 @@ EOF
   (assert (not (output-port-open? p)))
   (assert (= n 1)))
 
+;; bidirectional ports
+
+(let* ((b (string))
+       (w (lambda (s)
+           (set! b (string-append b s))))
+       (e (lambda ()
+           (positive? (string-length b))))
+       (r (lambda ()
+           (let ((s b))
+             (set! b (substring s 1))
+             (string-ref s 0))))
+       (i (make-input-port r e void))
+       (o (make-output-port w void))
+       (p (make-bidirectional-port i o)))
+  (assert (input-port? p))
+  (assert (output-port? p))
+  (assert (input-port-open? p))
+  (assert (output-port-open? p))
+  (display "quartz ruby" p)
+  (newline p)
+  (assert (equal? (read p) 'quartz))
+  (assert (equal? (read i) 'ruby))
+  (display "emerald topaz" p)
+  (newline p)
+  (close-output-port p)
+  (assert (not (output-port-open? o)))
+  (assert (not (output-port-open? p)))
+  (assert (equal? (read p) 'emerald))
+  (assert (equal? (read i) 'topaz))
+  (close-input-port p)
+  (assert (not (input-port-open? i)))
+  (assert (not (input-port-open? p))))
+
 ;; fill buffers
 (with-input-from-file "compiler.scm" read-string)
 
diff --git a/types.db b/types.db
index 3c3932c..06e292f 100644
--- a/types.db
+++ b/types.db
@@ -1849,6 +1849,7 @@
  (forall (a b) (#(procedure #:enforce) chicken.ports#port-map ((procedure (a) 
b) (procedure () a)) (list-of b))))
 
 (chicken.ports#port-fold (#(procedure #:enforce) chicken.ports#port-fold 
((procedure (* *) *) * (procedure () *)) *))
+(chicken.ports#make-bidirectional-port (#(procedure #:clean #:enforce) 
chicken.ports#make-bidirectional-port (input-port output-port) (refine (input 
output) port)))
 (chicken.ports#make-broadcast-port (#(procedure #:clean #:enforce) 
chicken.ports#make-broadcast-port (#!rest output-port) output-port))
 (chicken.ports#make-concatenated-port (#(procedure #:clean #:enforce) 
chicken.ports#make-concatenated-port (port #!rest input-port) input-port))
 (chicken.ports#with-error-to-port (#(procedure #:enforce) 
chicken.ports#with-error-to-port (output-port (procedure () . *)) . *))
-- 
2.1.4