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

@@ -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

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
 
+@cindex custom binary input/output ports
+@deffn {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
+@code{make-custom-binary-input-port} and
+@code{make-custom-binary-output-port}.  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.
+@end deffn
 
 @node Soft Ports
 @subsubsection Soft Ports

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
+@deffnx {Scheme Procedure} make-custom-binary-input/output-port id read! write! get-position set-position! close
 @xref{Custom Ports}.
 @end deffn
 

libguile/r6rs-ports.c

@@ -946,6 +946,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.  */
@@ -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 ();
 }

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);

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).

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