~ chicken-core (chicken-5) b00218d724bbcd1006a94019eb0ebc90ebdc2584
commit b00218d724bbcd1006a94019eb0ebc90ebdc2584
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Thu Jun 30 20:09:49 2016 +1200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sat Jul 9 16:26:41 2016 +0200
Add new `make-bidirectional-port` procedure to ports unit
This allows an input and output port to be combined into a single
bidirectional port.
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/NEWS b/NEWS
index 775ee576..9c24d815 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 be9c61ae..c222fd7e 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 9e4d22e4..fc8fde46 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 33390c47..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 2fc19a08..0f5fdbbb 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 3c3932c0..06e292f6 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 () . *)) . *))
Trap