peek-byte in Scheme

* libguile/ports.c (trampoline_to_c_read, trampoline_to_c_write): Since
  C might assume that the indices are within bounds of the bytevector,
  verify them more here.
  (scm_port_random_access_p, scm_port_read_buffering)
  (scm_set_port_read_buffer, scm_port_read, scm_port_write): New helpers
  exposed to (ice-9 ports).
  (scm_port_read_buffer, scm_port_write_buffer): Don't flush or validate
  port mode; we do that in Scheme.
* module/ice-9/ports.scm: Implement enough of port machinery to
  implement peek-byte in Scheme.  Not yet exported.

3 files changed, 166 insertions, 27 deletions

diff --git a/libguile/ports.c b/libguile/ports.c
index 058d7dcf3..319b5f5fa 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -258,11 +258,20 @@ scm_make_port_type (char *name,
 
 static SCM
 trampoline_to_c_read (SCM port, SCM dst, SCM start, SCM count)
+#define FUNC_NAME "port-read"
 {
+  size_t c_start, c_count;
+
+  SCM_VALIDATE_OPPORT (1, port);
+  c_start = scm_to_size_t (start);
+  c_count = scm_to_size_t (count);
+  SCM_ASSERT_RANGE (2, start, start <= count);
+  SCM_ASSERT_RANGE (3, count, c_start+c_count <= scm_c_bytevector_length (dst));
+
   return scm_from_size_t
-    (SCM_PORT_DESCRIPTOR (port)->c_read
-     (port, dst, scm_to_size_t (start), scm_to_size_t (count)));
+    (SCM_PORT_DESCRIPTOR (port)->c_read (port, dst, c_start, c_count));
 }
+#undef FUNC_NAME
 
 static size_t
 trampoline_to_scm_read (SCM port, SCM dst, size_t start, size_t count)
@@ -274,11 +283,20 @@ trampoline_to_scm_read (SCM port, SCM dst, size_t start, size_t count)
 
 static SCM
 trampoline_to_c_write (SCM port, SCM src, SCM start, SCM count)
+#define FUNC_NAME "port-write"
 {
+  size_t c_start, c_count;
+
+  SCM_VALIDATE_OPPORT (1, port);
+  c_start = scm_to_size_t (start);
+  c_count = scm_to_size_t (count);
+  SCM_ASSERT_RANGE (2, start, c_start <= c_count);
+  SCM_ASSERT_RANGE (3, count, c_start+c_count <= scm_c_bytevector_length (src));
+
   return scm_from_size_t
-    (SCM_PORT_DESCRIPTOR (port)->c_write
-     (port, src, scm_to_size_t (start), scm_to_size_t (count)));
+    (SCM_PORT_DESCRIPTOR (port)->c_write (port, src, c_start, c_count));
 }
+#undef FUNC_NAME
 
 static size_t
 trampoline_to_scm_write (SCM port, SCM src, size_t start, size_t count)
@@ -2457,43 +2475,75 @@ scm_fill_input (SCM port)
   return read_buf;
 }
 
-SCM_DEFINE (scm_port_read_buffer, "port-read-buffer", 1, 0, 0,
+SCM_DEFINE (scm_port_random_access_p, "port-random-access?", 1, 0, 0,
             (SCM port),
-	    "Return the read buffer for a port.  If the port is\n"
-            "random-access, its write buffer, if any, will be flushed\n"
-            "if needed.")
-#define FUNC_NAME s_scm_port_read_buffer
+	    "Return true if the port is random-access, or false otherwise.")
+#define FUNC_NAME s_scm_port_random_access_p
 {
-  scm_t_port *pt;
+  SCM_VALIDATE_OPPORT (1, port);
+  return scm_from_bool (SCM_PTAB_ENTRY (port)->rw_random);
+}
+#undef FUNC_NAME
 
+SCM_DEFINE (scm_port_read_buffering, "port-read-buffering", 1, 0, 0,
+            (SCM port),
+	    "Return the amount of read buffering on a port, in bytes.")
+#define FUNC_NAME s_scm_port_read_buffering
+{
   SCM_VALIDATE_OPINPORT (1, port);
+  return scm_from_size_t (SCM_PTAB_ENTRY (port)->read_buffering);
+}
+#undef FUNC_NAME
 
-  pt = SCM_PTAB_ENTRY (port);
-
-  if (pt->rw_random)
-    scm_flush (pt->port);
+SCM_DEFINE (scm_set_port_read_buffer_x, "set-port-read-buffer!", 2, 0, 0,
+            (SCM port, SCM buf),
+	    "Reset the read buffer on an input port.")
+#define FUNC_NAME s_scm_set_port_read_buffer_x
+{
+  SCM_VALIDATE_OPINPORT (1, port);
+  SCM_ASSERT_TYPE (scm_is_vector (buf) && scm_c_vector_length (buf) >= 4,
+                   buf, 2, FUNC_NAME, "port buffer");
+  SCM_PTAB_ENTRY (port)->read_buf = buf;
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
 
-  return pt->read_buf;
+SCM_DEFINE (scm_port_read, "port-read", 1, 0, 0, (SCM port),
+	    "Return the read function for an input port.")
+#define FUNC_NAME s_scm_port_read
+{
+  SCM_VALIDATE_OPINPORT (1, port);
+  return SCM_PORT_DESCRIPTOR (port)->scm_read;
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_port_write_buffer, "port-write-buffer", 1, 0, 0,
+SCM_DEFINE (scm_port_write, "port-write", 1, 0, 0,
             (SCM port),
-	    "Return the write buffer for a port.  If the port is\n"
-            "random-access, its read buffer, if any, will be discarded\n"
-            "if needed.")
-#define FUNC_NAME s_scm_port_write_buffer
+	    "Return the write function for an output port.")
+#define FUNC_NAME s_scm_port_write
 {
-  scm_t_port *pt;
-
   SCM_VALIDATE_OPOUTPORT (1, port);
+  return SCM_PORT_DESCRIPTOR (port)->scm_write;
+}
+#undef FUNC_NAME
 
-  pt = SCM_PTAB_ENTRY (port);
-
-  if (pt->rw_random)
-    scm_end_input (pt->port);
+SCM_DEFINE (scm_port_read_buffer, "port-read-buffer", 1, 0, 0,
+            (SCM port),
+	    "Return the read buffer for a port.")
+#define FUNC_NAME s_scm_port_read_buffer
+{
+  SCM_VALIDATE_OPPORT (1, port);
+  return SCM_PTAB_ENTRY (port)->read_buf;
+}
+#undef FUNC_NAME
 
-  return pt->write_buf;
+SCM_DEFINE (scm_port_write_buffer, "port-write-buffer", 1, 0, 0,
+            (SCM port),
+	    "Return the write buffer for a port.")
+#define FUNC_NAME s_scm_port_write_buffer
+{
+  SCM_VALIDATE_OPPORT (1, port);
+  return SCM_PTAB_ENTRY (port)->write_buf;
 }
 #undef FUNC_NAME
 
diff --git a/libguile/ports.h b/libguile/ports.h
index ba4bc2c3a..2a6e42c8b 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -316,6 +316,12 @@ SCM_API SCM scm_drain_input (SCM port);
 SCM_API void scm_end_input (SCM port);
 SCM_API SCM scm_force_output (SCM port);
 SCM_API void scm_flush (SCM port);
+
+SCM_INTERNAL SCM scm_port_random_access_p (SCM port);
+SCM_INTERNAL SCM scm_port_read_buffering (SCM port);
+SCM_INTERNAL SCM scm_set_port_read_buffer_x (SCM port, SCM buf);
+SCM_INTERNAL SCM scm_port_read (SCM port);
+SCM_INTERNAL SCM scm_port_write (SCM port);
 SCM_INTERNAL SCM scm_port_read_buffer (SCM port);
 SCM_INTERNAL SCM scm_port_write_buffer (SCM port);
 
diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm
index 388b2584a..8051549eb 100644
--- a/module/ice-9/ports.scm
+++ b/module/ice-9/ports.scm
@@ -26,6 +26,7 @@
 
 
 (define-module (ice-9 ports)
+  #:use-module (rnrs bytevectors)
   #:export (;; Definitions from ports.c.
             %port-property
             %set-port-property!
@@ -153,6 +154,88 @@
 
 
 
+(define-syntax-rule (port-buffer-bytevector buf) (vector-ref buf 0))
+(define-syntax-rule (port-buffer-cur buf) (vector-ref buf 1))
+(define-syntax-rule (port-buffer-end buf) (vector-ref buf 2))
+(define-syntax-rule (port-buffer-has-eof? buf) (vector-ref buf 3))
+
+(define-syntax-rule (set-port-buffer-cur! buf cur)
+  (vector-set! buf 1 cur))
+(define-syntax-rule (set-port-buffer-end! buf end)
+  (vector-set! buf 2 end))
+(define-syntax-rule (set-port-buffer-has-eof?! buf has-eof?)
+  (vector-set! buf 3 has-eof?))
+
+(define (make-port-buffer size)
+  (vector (make-bytevector size 0) 0 0 #f))
+
+(define (write-bytes port src start count)
+  (let ((written ((port-write port) port src start count)))
+    (unless (<= 0 written count)
+      (error "bad return from port write function" written))
+    (when (< written count)
+      (write-bytes port src (+ start written) (- count written)))))
+
+(define (flush-output port)
+  (let* ((buf (port-write-buffer port))
+         (cur (port-buffer-cur buf))
+         (end (port-buffer-end buf)))
+    (when (< cur end)
+      ;; Update cursors before attempting to write, assuming that I/O
+      ;; errors are sticky.  That way if the write throws an error,
+      ;; causing the computation to abort, and possibly causing the port
+      ;; to be collected by GC when it's open, any subsequent close-port
+      ;; or force-output won't signal *another* error.
+      (set-port-buffer-cur! buf 0)
+      (set-port-buffer-end! buf 0)
+      (write-bytes port (port-buffer-bytevector buf) cur (- end cur)))))
+
+(define (read-bytes port dst start count)
+  (let ((read ((port-read port) port dst start count)))
+    (unless (<= 0 read count)
+      (error "bad return from port read function" read))
+    read))
+
+(define (fill-input port)
+  (let ((buf (port-read-buffer port)))
+    (cond
+     ((or (< (port-buffer-cur buf) (port-buffer-end buf))
+          (port-buffer-has-eof? buf))
+      buf)
+     (else
+      (unless (input-port? port)
+        (error "not an input port" port))
+      (when (port-random-access? port)
+        (flush-output port))
+      (let* ((read-buffering (port-read-buffering port))
+             (buf (if (= (bytevector-length (port-buffer-bytevector buf))
+                         read-buffering)
+                      buf
+                      (let ((buf (make-port-buffer read-buffering)))
+                        (set-port-read-buffer! port buf)
+                        buf)))
+             (bv (port-buffer-bytevector buf))
+             (start (port-buffer-end buf))
+             (count (- (bytevector-length bv) start))
+             (read (read-bytes port bv start count)))
+        (set-port-buffer-end! buf (+ start read))
+        (set-port-buffer-has-eof?! buf (zero? count))
+        buf)))))
+
+(define (peek-byte port)
+  (let* ((buf (port-read-buffer port))
+         (cur (port-buffer-cur buf)))
+    (if (< cur (port-buffer-end buf))
+        (bytevector-u8-ref (port-buffer-bytevector buf) cur)
+        (let* ((buf (fill-input port))
+               (cur (port-buffer-cur buf)))
+          (if (< cur (port-buffer-end buf))
+              (bytevector-u8-ref (port-buffer-bytevector buf) cur)
+              the-eof-object)))))
+
+
+
+
 ;;; Current ports as parameters.
 ;;;