Move bytevector input ports implementation to Scheme

* module/ice-9/binary-ports.scm (open-bytevector-input-port): New
implementation.
* libguile/r6rs-ports.c (scm_open_bytevector_input_port): Proxy to
Scheme.

libguile/r6rs-ports.c

@@ -55,22 +55,6 @@ SCM_SYMBOL (sym_ISO_8859_1, "ISO-8859-1");
 SCM_SYMBOL (sym_error, "error");
 
 
-
-
-/* Unimplemented features.  */
-
-
-/* Transoders are currently not implemented since Guile 1.8 is not
-   Unicode-capable.  Thus, most of the code here assumes the use of the
-   binary transcoder.  */
-static inline void
-transcoders_not_implemented (void)
-{
-  fprintf (stderr, "%s: warning: transcoders not implemented\n",
-	   PACKAGE_NAME);
-}
-
-
 
 
 /* End-of-file object.  */
@@ -85,118 +69,6 @@ SCM_DEFINE (scm_eof_object, "eof-object", 0, 0, 0,
 #undef FUNC_NAME
 
 
-
-
-/* Input ports.  */
-
-#define MAX(A, B) ((A) >= (B) ? (A) : (B))
-#define MIN(A, B) ((A) < (B) ? (A) : (B))
-
-/* Bytevector input ports.  */
-static scm_t_port_type *bytevector_input_port_type = 0;
-
-struct bytevector_input_port {
-  SCM bytevector;
-  size_t pos;
-};
-
-static inline SCM
-make_bytevector_input_port (SCM bv)
-{
-  const unsigned long mode_bits = SCM_RDNG;
-  struct bytevector_input_port *stream;
-
-  stream = scm_gc_typed_calloc (struct bytevector_input_port);
-  stream->bytevector = bv;
-  stream->pos = 0;
-  return scm_c_make_port_with_encoding (bytevector_input_port_type, mode_bits,
-                                        sym_ISO_8859_1, sym_error,
-                                        (scm_t_bits) stream);
-}
-
-static size_t
-bytevector_input_port_read (SCM port, SCM dst, size_t start, size_t count)
-{
-  size_t remaining;
-  struct bytevector_input_port *stream = (void *) SCM_STREAM (port);
-
-  if (stream->pos >= SCM_BYTEVECTOR_LENGTH (stream->bytevector))
-    return 0;
-
-  remaining = SCM_BYTEVECTOR_LENGTH (stream->bytevector) - stream->pos;
-  if (remaining < count)
-    count = remaining;
-
-  memcpy (SCM_BYTEVECTOR_CONTENTS (dst) + start,
-          SCM_BYTEVECTOR_CONTENTS (stream->bytevector) + stream->pos,
-          count);
-
-  stream->pos += count;
-
-  return count;
-}
-
-static scm_t_off
-bytevector_input_port_seek (SCM port, scm_t_off offset, int whence)
-#define FUNC_NAME "bytevector_input_port_seek"
-{
-  struct bytevector_input_port *stream = (void *) SCM_STREAM (port);
-  size_t base;
-  scm_t_off target;
-
-  if (whence == SEEK_CUR)
-    base = stream->pos;
-  else if (whence == SEEK_SET)
-    base = 0;
-  else if (whence == SEEK_END)
-    base = SCM_BYTEVECTOR_LENGTH (stream->bytevector);
-  else
-    scm_wrong_type_arg_msg (FUNC_NAME, 0, port, "invalid `seek' parameter");
-
-  if (base > SCM_T_OFF_MAX
-      || INT_ADD_OVERFLOW ((scm_t_off) base, offset))
-    scm_num_overflow (FUNC_NAME);
-  target = (scm_t_off) base + offset;
-
-  if (target >= 0 && target <= SCM_BYTEVECTOR_LENGTH (stream->bytevector))
-    stream->pos = target;
-  else
-    scm_out_of_range (FUNC_NAME, scm_from_off_t (offset));
-
-  return target;
-}
-#undef FUNC_NAME
-
-
-/* Instantiate the bytevector input port type.  */
-static inline void
-initialize_bytevector_input_ports (void)
-{
-  bytevector_input_port_type =
-    scm_make_port_type ("r6rs-bytevector-input-port",
-                        bytevector_input_port_read,
-			NULL);
-
-  scm_set_port_seek (bytevector_input_port_type, bytevector_input_port_seek);
-}
-
-
-SCM_DEFINE (scm_open_bytevector_input_port,
-	    "open-bytevector-input-port", 1, 1, 0,
-	    (SCM bv, SCM transcoder),
-	    "Return an input port whose contents are drawn from "
-	    "bytevector @var{bv}.")
-#define FUNC_NAME s_scm_open_bytevector_input_port
-{
-  SCM_VALIDATE_BYTEVECTOR (1, bv);
-  if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder))
-    transcoders_not_implemented ();
-
-  return make_bytevector_input_port (bv);
-}
-#undef FUNC_NAME
-
-
 
 
 /* Binary input.  */
@@ -351,6 +223,8 @@ SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+#define MIN(A, B) ((A) < (B) ? (A) : (B))
+
 SCM_DEFINE (scm_get_bytevector_some_x, "get-bytevector-some!", 4, 0, 0,
 	    (SCM port, SCM bv, SCM start, SCM count),
             "Read up to @var{count} bytes from @var{port}, blocking "
@@ -518,18 +392,31 @@ SCM_DEFINE (scm_unget_bytevector, "unget-bytevector", 2, 2, 0,
 
 
 
-/* Bytevector output port.  */
+/* Bytevector input and output ports.  */
 
+static SCM open_bytevector_input_port_var;
 static SCM open_bytevector_output_port_var;
 static scm_i_pthread_once_t bytevector_port_vars = SCM_I_PTHREAD_ONCE_INIT;
 
 static void
 init_bytevector_port_vars (void)
 {
+  open_bytevector_input_port_var =
+    scm_c_public_lookup ("ice-9 binary-ports", "open-bytevector-input-port");
   open_bytevector_output_port_var =
     scm_c_public_lookup ("ice-9 binary-ports", "open-bytevector-output-port");
 }
 
+SCM
+scm_open_bytevector_input_port (SCM bv, SCM transcoder)
+{
+  scm_i_pthread_once (&bytevector_port_vars, init_bytevector_port_vars);
+  return SCM_UNBNDP (transcoder)
+    ? scm_call_1 (scm_variable_ref (open_bytevector_input_port_var), bv)
+    : scm_call_2 (scm_variable_ref (open_bytevector_input_port_var), bv,
+                  transcoder);
+}
+
 SCM
 scm_open_bytevector_output_port (SCM transcoder)
 {
@@ -724,7 +611,6 @@ scm_register_r6rs_ports (void)
 			    (scm_t_extension_init_func) scm_init_r6rs_ports,
 			    NULL);
 
-  initialize_bytevector_input_ports ();
   initialize_transcoded_ports ();
 }
 

module/ice-9/binary-ports.scm

@@ -53,6 +53,9 @@
 ;; Note that this extension also defines %make-transcoded-port, which is
 ;; not exported but is used by (rnrs io ports).
 
+(load-extension (string-append "libguile-" (effective-version))
+                "scm_init_r6rs_ports")
+
 (define (bytevector-concatenate-reverse bvs)
   (let* ((len (let lp ((bvs bvs) (len 0))
                 (match bvs
@@ -73,7 +76,42 @@
   (let ((dst (make-bytevector count)))
     (bytevector-copy! src start dst 0 count)
     dst))
-  
+
+(define* (open-bytevector-input-port src #:optional transcoder)
+  "Return an input port whose contents are drawn from bytevector @var{src}."
+  (unless (bytevector? src)
+    (error "not a bytevector" src))
+  (when transcoder
+    (error "transcoders not implemented"))
+  (define pos 0)
+  (define (bv-read port dst start count)
+    (let ((to-copy (min count (- (bytevector-length src) pos))))
+      (bytevector-copy! src pos dst start to-copy)
+      (set! pos (+ pos to-copy))
+      to-copy))
+
+  (define (bv-seek port offset whence)
+    (define len (bytevector-length src))
+    (define base
+      (cond
+       ((eq? whence SEEK_SET) 0)
+       ((eq? whence SEEK_CUR) pos)
+       ((eq? whence SEEK_END) len)
+       (else (error "bad whence value" whence))))
+    (define dst (+ base offset))
+    (unless (<= 0 dst len)
+      (error "out of range" dst))
+    (set! pos dst)
+    dst)
+
+  (make-custom-port #:id "bytevector-input-port"
+                    #:read bv-read
+                    #:seek bv-seek
+                    #:random-access? (lambda (_) #t)
+                    ;; FIXME: Instead default to current encoding, if
+                    ;; someone reads text from this port.
+                    #:encoding 'ISO-8859-1 #:conversion-strategy 'error))
+
 (define* (open-bytevector-output-port #:optional transcoder)
   "Return two values: an output port and a procedure.  The latter should be
 called with zero arguments to obtain a bytevector containing the data
@@ -143,9 +181,6 @@ accumulated by the port."
               (force-output port))
             (get-output-bytevector))))
 
-(load-extension (string-append "libguile-" (effective-version))
-                "scm_init_r6rs_ports")
-
 (define (call-with-input-bytevector bv proc)
   "Call the one-argument procedure @var{proc} with a newly created
 binary input port from which the bytevector @var{bv}'s contents may be