[Guile-commits] 01/01: Implement R6RS custom binary input/output ports

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 1a1c3bbe597f3682066266ce44bf9bbed2481ad2
Author: Andy Wingo <address@hidden>
Date:   Thu Aug 4 22:29:51 2016 +0200

    Implement R6RS custom binary input/output ports
    
    * NEWS: Add new feature.
    * doc/ref/r6rs.texi (rnrs io ports):
    * doc/ref/api-io.texi (Custom Ports): Document new procedure.
    * libguile/r6rs-ports.h:
    * libguile/r6rs-ports.c (make_custom_binary_input_output_port)
      (scm_make_custom_binary_input_output_port)
      (custom_binary_input_output_port_random_access_p)
      (initialize_custom_binary_input_output_ports)
      (scm_init_r6rs_ports): Implement custom binary input/output ports.
    * module/rnrs/io/ports.scm (rnrs):
    * module/ice-9/binary-ports.scm (ice-9): Export
      make-custom-binary-input/output-port.
---
 NEWS                          |    1 +
 doc/ref/api-io.texi           |   12 ++++++
 doc/ref/r6rs.texi             |    1 +
 libguile/r6rs-ports.c         |   86 +++++++++++++++++++++++++++++++++++++++++
 libguile/r6rs-ports.h         |    2 +
 module/ice-9/binary-ports.scm |    3 +-
 module/rnrs/io/ports.scm      |    1 +
 7 files changed, 105 insertions(+), 1 deletion(-)

diff --git a/NEWS b/NEWS
index 5286a43..75e0988 100644
--- a/NEWS
+++ b/NEWS
@@ -12,6 +12,7 @@ Changes in 2.1.4 (changes since the 2.1.3 alpha release):
 * New interfaces
 
 ** Implement R6RS output-buffer-mode
+** Implement R6RS custom binary input/output ports
 ** Implement R6RS bytevector->string, string->bytevector
 
 * New deprecations
diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi
index 2362053..76c8db8 100644
--- a/doc/ref/api-io.texi
+++ b/doc/ref/api-io.texi
@@ -1299,6 +1299,18 @@ though an end-of-file was sent to the byte sink.
 The other arguments are as for @code{make-custom-binary-input-port}.
 @end deffn
 
address@hidden custom binary input/output ports
address@hidden {Scheme Procedure} make-custom-binary-input/output-port id read! 
write! get-position set-position! close
+Return a new custom binary input/output port named @var{id} (a string).
+The various arguments are the same as for The other arguments are as for
address@hidden and
address@hidden  If buffering is enabled on the
+port, as is the case by default, input will be buffered in both
+directions; @xref{Buffering}.  If the @var{set-position!} function is
+provided and not @code{#f}, then the port will also be marked as
+random-access, causing the buffer to be flushed between reads and
+writes.
address@hidden deffn
 
 @node Soft Ports
 @subsubsection Soft Ports
diff --git a/doc/ref/r6rs.texi b/doc/ref/r6rs.texi
index eaee821..fa8d7d2 100644
--- a/doc/ref/r6rs.texi
+++ b/doc/ref/r6rs.texi
@@ -1757,6 +1757,7 @@ respectively.  Whether the port supports the 
@code{port-position} and
 
 @deffn {Scheme Procedure} make-custom-binary-input-port id read! get-position 
set-position! close
 @deffnx {Scheme Procedure} make-custom-binary-output-port id write! 
get-position set-position! close
address@hidden {Scheme Procedure} make-custom-binary-input/output-port id read! 
write! get-position set-position! close
 @xref{Custom Ports}.
 @end deffn
 
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
index c53b53b..b52eb85 100644
--- a/libguile/r6rs-ports.c
+++ b/libguile/r6rs-ports.c
@@ -948,6 +948,91 @@ initialize_custom_binary_output_ports (void)
 
 
 
+/* Custom binary input_output ports.  */
+
+static scm_t_port_type *custom_binary_input_output_port_type;
+
+
+static inline SCM
+make_custom_binary_input_output_port (SCM read_proc, SCM write_proc,
+                                      SCM get_position_proc,
+                                      SCM set_position_proc, SCM close_proc)
+{
+  struct custom_binary_port *stream;
+  const unsigned long mode_bits = SCM_WRTNG | SCM_RDNG;
+
+  stream = scm_gc_typed_calloc (struct custom_binary_port);
+  stream->read = read_proc;
+  stream->write = write_proc;
+  stream->get_position = get_position_proc;
+  stream->set_position_x = set_position_proc;
+  stream->close = close_proc;
+
+  return scm_c_make_port_with_encoding (custom_binary_input_output_port_type,
+                                        mode_bits, sym_ISO_8859_1, sym_error,
+                                        (scm_t_bits) stream);
+}
+
+SCM_DEFINE (scm_make_custom_binary_input_output_port,
+           "make-custom-binary-input/output-port", 6, 0, 0,
+           (SCM id, SCM read_proc, SCM write_proc, SCM get_position_proc,
+            SCM set_position_proc, SCM close_proc),
+           "Return a new custom binary input/output port.  The port's input\n"
+            "is drained by invoking @var{read_proc} and passing it a\n"
+            "bytevector, an index where octets should be written, and an\n"
+            "octet count.  The output is drained by invoking 
@var{write_proc}\n"
+            "and passing it a bytevector, an index where octets should be\n"
+            "written, and an octet count.")
+#define FUNC_NAME s_scm_make_custom_binary_input_output_port
+{
+  SCM_VALIDATE_STRING (1, id);
+  SCM_VALIDATE_PROC (2, read_proc);
+  SCM_VALIDATE_PROC (3, write_proc);
+
+  if (!scm_is_false (get_position_proc))
+    SCM_VALIDATE_PROC (4, get_position_proc);
+
+  if (!scm_is_false (set_position_proc))
+    SCM_VALIDATE_PROC (5, set_position_proc);
+
+  if (!scm_is_false (close_proc))
+    SCM_VALIDATE_PROC (6, close_proc);
+
+  return make_custom_binary_input_output_port
+    (read_proc, write_proc, get_position_proc, set_position_proc, close_proc);
+}
+#undef FUNC_NAME
+
+
+static int
+custom_binary_input_output_port_random_access_p (SCM port)
+{
+  struct custom_binary_port *stream = (void *) SCM_STREAM (port);
+
+  return scm_is_true (stream->set_position_x);
+}
+
+
+/* Instantiate the custom binary input_output port type.  */
+static inline void
+initialize_custom_binary_input_output_ports (void)
+{
+  custom_binary_input_output_port_type =
+    scm_make_port_type ("r6rs-custom-binary-input/output-port",
+                       custom_binary_input_port_read,
+                       custom_binary_output_port_write);
+
+  scm_set_port_seek (custom_binary_input_output_port_type,
+                     custom_binary_port_seek);
+  scm_set_port_random_access_p (custom_binary_input_output_port_type,
+                                
custom_binary_input_output_port_random_access_p);
+  scm_set_port_close (custom_binary_input_output_port_type,
+                      custom_binary_port_close);
+}
+
+
+
+
 /* Transcoded ports.  */
 
 static scm_t_port_type *transcoded_port_type = 0;
@@ -1082,5 +1167,6 @@ scm_init_r6rs_ports (void)
   initialize_custom_binary_input_ports ();
   initialize_bytevector_output_ports ();
   initialize_custom_binary_output_ports ();
+  initialize_custom_binary_input_output_ports ();
   initialize_transcoded_ports ();
 }
diff --git a/libguile/r6rs-ports.h b/libguile/r6rs-ports.h
index 3dde4d5..a2c63c7 100644
--- a/libguile/r6rs-ports.h
+++ b/libguile/r6rs-ports.h
@@ -39,6 +39,8 @@ SCM_API SCM scm_put_u8 (SCM, SCM);
 SCM_API SCM scm_put_bytevector (SCM, SCM, SCM, SCM);
 SCM_API SCM scm_open_bytevector_output_port (SCM);
 SCM_API SCM scm_make_custom_binary_output_port (SCM, SCM, SCM, SCM, SCM);
+SCM_API SCM scm_make_custom_binary_input_output_port (SCM, SCM, SCM,
+                                                      SCM, SCM, SCM);
 SCM_API SCM scm_get_string_n_x (SCM, SCM, SCM, SCM);
 
 SCM_API void scm_init_r6rs_ports (void);
diff --git a/module/ice-9/binary-ports.scm b/module/ice-9/binary-ports.scm
index 9d6c945..e0da3df 100644
--- a/module/ice-9/binary-ports.scm
+++ b/module/ice-9/binary-ports.scm
@@ -42,7 +42,8 @@
             put-bytevector
             unget-bytevector
             open-bytevector-output-port
-            make-custom-binary-output-port))
+            make-custom-binary-output-port
+            make-custom-binary-input/output-port))
 
 ;; Note that this extension also defines %make-transcoded-port, which is
 ;; not exported but is used by (rnrs io ports).
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
index 5ddc3d5..e924ad8 100644
--- a/module/rnrs/io/ports.scm
+++ b/module/rnrs/io/ports.scm
@@ -71,6 +71,7 @@
 
           ;; input/output ports
           open-file-input/output-port
+          make-custom-binary-input/output-port
 
           ;; binary output
           put-u8 put-bytevector