[Guile-commits] 06/18: Rewrite custom binary ports in Scheme, in terms of custom ports

[Andy Wingo]

wingo pushed a commit to branch main
in repository guile.

commit 0e305e6bfda397fbe1e4d2a7c29de6bdbacc206d
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Sat May 27 22:55:40 2023 +0200

    Rewrite custom binary ports in Scheme, in terms of custom ports
    
    * libguile/r6rs-ports.c: Call out to Scheme instead of defining here.
    * libguile/r6rs-ports.h: Put custom binary port decls together, to
    deprecate later.
    * module/ice-9/binary-ports.scm: Re-implement custom binary ports in
    terms of custom ports.
---
 libguile/r6rs-ports.c         | 361 +++---------------------------------------
 libguile/r6rs-ports.h         |   6 +-
 module/ice-9/binary-ports.scm | 115 +++++++++++++-
 3 files changed, 142 insertions(+), 340 deletions(-)

diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
index 49ca05325..2e4fc9452 100644
--- a/libguile/r6rs-ports.c
+++ b/libguile/r6rs-ports.c
@@ -1,4 +1,4 @@
-/* Copyright 2009-2011,2013-2015,2018-2019
+/* Copyright 2009-2011,2013-2015,2018-2019,2023
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -32,6 +32,7 @@
 #include "eval.h"
 #include "extensions.h"
 #include "gsubr.h"
+#include "modules.h"
 #include "numbers.h"
 #include "ports-internal.h"
 #include "procs.h"
@@ -196,179 +197,6 @@ SCM_DEFINE (scm_open_bytevector_input_port,
 
 
 
-/* Custom binary ports.  The following routines are shared by input and
-   output custom binary ports.  */
-
-struct custom_binary_port {
-  SCM read;
-  SCM write;
-  SCM get_position;
-  SCM set_position_x;
-  SCM close;
-};
-
-static int
-custom_binary_port_random_access_p (SCM port)
-{
-  struct custom_binary_port *stream = (void *) SCM_STREAM (port);
-
-  return scm_is_true (stream->set_position_x);
-}
-
-static scm_t_off
-custom_binary_port_seek (SCM port, scm_t_off offset, int whence)
-#define FUNC_NAME "custom_binary_port_seek"
-{
-  SCM result;
-  struct custom_binary_port *stream = (void *) SCM_STREAM (port);
-  scm_t_off c_result = 0;
-
-  switch (whence)
-    {
-    case SEEK_CUR:
-      {
-       if (SCM_LIKELY (scm_is_true (stream->get_position)))
-         result = scm_call_0 (stream->get_position);
-       else
-         scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
-                                 "R6RS custom binary port with "
-                                 "`port-position' support");
-       c_result = scm_to_off_t (result);
-       if (offset == 0)
-         /* We just want to know the current position.  */
-         break;
-
-        if (INT_ADD_OVERFLOW (offset, c_result))
-          scm_num_overflow (FUNC_NAME);
-
-       offset += c_result;
-       /* Fall through.  */
-      }
-
-    case SEEK_SET:
-      {
-       if (SCM_LIKELY (scm_is_true (stream->set_position_x)))
-         result = scm_call_1 (stream->set_position_x, scm_from_off_t (offset));
-       else
-         scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
-                                 "seekable R6RS custom binary port");
-
-       /* Assuming setting the position succeeded.  */
-       c_result = offset;
-       break;
-      }
-
-    default:
-      /* `SEEK_END' cannot be supported.  */
-      scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
-                             "R6RS custom binary ports do not "
-                             "support `SEEK_END'");
-    }
-
-  return c_result;
-}
-#undef FUNC_NAME
-
-static void
-custom_binary_port_close (SCM port)
-{
-  struct custom_binary_port *stream = (void *) SCM_STREAM (port);
-
-  if (scm_is_true (stream->close))
-    /* Invoke the `close' thunk.  */
-    scm_call_0 (stream->close);
-}
-
-
-
-
-/* Custom binary input ports.  */
-
-static scm_t_port_type *custom_binary_input_port_type = 0;
-
-static inline SCM
-make_custom_binary_input_port (SCM read_proc, SCM get_position_proc,
-                               SCM set_position_proc, SCM close_proc)
-{
-  struct custom_binary_port *stream;
-  const unsigned long mode_bits = SCM_RDNG;
-
-  stream = scm_gc_typed_calloc (struct custom_binary_port);
-  stream->read = read_proc;
-  stream->write = SCM_BOOL_F;
-  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_port_type,
-                                        mode_bits,
-                                        sym_ISO_8859_1, sym_error,
-                                        (scm_t_bits) stream);
-}
-
-static size_t
-custom_binary_input_port_read (SCM port, SCM dst, size_t start, size_t count)
-#define FUNC_NAME "custom_binary_input_port_read"
-{
-  struct custom_binary_port *stream = (void *) SCM_STREAM (port);
-  SCM octets;
-  size_t c_octets;
-
-  octets = scm_call_3 (stream->read, dst, scm_from_size_t (start),
-                       scm_from_size_t (count));
-  c_octets = scm_to_size_t (octets);
-  if (c_octets > count)
-    scm_out_of_range (FUNC_NAME, octets);
-
-  return c_octets;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_make_custom_binary_input_port,
-           "make-custom-binary-input-port", 5, 0, 0,
-           (SCM id, SCM read_proc, SCM get_position_proc,
-            SCM set_position_proc, SCM close_proc),
-           "Return a new custom binary input port whose input is drained "
-           "by invoking @var{read_proc} and passing it a bytevector, an "
-           "index where octets should be written, and an octet count.")
-#define FUNC_NAME s_scm_make_custom_binary_input_port
-{
-  SCM_VALIDATE_STRING (1, id);
-  SCM_VALIDATE_PROC (2, read_proc);
-
-  if (!scm_is_false (get_position_proc))
-    SCM_VALIDATE_PROC (3, get_position_proc);
-
-  if (!scm_is_false (set_position_proc))
-    SCM_VALIDATE_PROC (4, set_position_proc);
-
-  if (!scm_is_false (close_proc))
-    SCM_VALIDATE_PROC (5, close_proc);
-
-  return make_custom_binary_input_port (read_proc, get_position_proc,
-                                        set_position_proc, close_proc);
-}
-#undef FUNC_NAME
-
-
-/* Instantiate the custom binary input port type.  */
-static inline void
-initialize_custom_binary_input_ports (void)
-{
-  custom_binary_input_port_type =
-    scm_make_port_type ("r6rs-custom-binary-input-port",
-                       custom_binary_input_port_read, NULL);
-
-  scm_set_port_seek (custom_binary_input_port_type, custom_binary_port_seek);
-  scm_set_port_random_access_p (custom_binary_input_port_type,
-                                custom_binary_port_random_access_p);
-  scm_set_port_close (custom_binary_input_port_type, custom_binary_port_close);
-}
-
-
-
-
 /* Binary input.  */
 
 /* We currently don't support specific binary input ports.  */
@@ -941,169 +769,35 @@ initialize_bytevector_output_ports (void)
 
 
 
-/* Custom binary output ports.  */
+/* Custom ports.  */
 
-static scm_t_port_type *custom_binary_output_port_type;
-
-
-static inline SCM
-make_custom_binary_output_port (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;
-
-  stream = scm_gc_typed_calloc (struct custom_binary_port);
-  stream->read = SCM_BOOL_F;
-  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_output_port_type,
-                                        mode_bits,
-                                        sym_ISO_8859_1, sym_error,
-                                        (scm_t_bits) stream);
+SCM scm_make_custom_binary_input_port (SCM id, SCM read_proc,
+                                       SCM get_position_proc,
+                                       SCM set_position_proc, SCM close_proc) {
+  return scm_call_5 (scm_c_public_ref ("ice-9 binary-ports",
+                                       "make-custom-binary-input-port"),
+                     id, read_proc, get_position_proc, set_position_proc,
+                     close_proc);
 }
 
-/* Flush octets from BUF to the backing store.  */
-static size_t
-custom_binary_output_port_write (SCM port, SCM src, size_t start, size_t count)
-#define FUNC_NAME "custom_binary_output_port_write"
-{
-  struct custom_binary_port *stream = (void *) SCM_STREAM (port);
-  size_t written;
-  SCM result;
-
-  result = scm_call_3 (stream->write, src, scm_from_size_t (start),
-                       scm_from_size_t (count));
-
-  written = scm_to_size_t (result);
-  if (written > count)
-    scm_wrong_type_arg_msg (FUNC_NAME, 0, result,
-                            "R6RS custom binary output port `write!' "
-                            "returned a incorrect integer");
-
-  return written;
+SCM scm_make_custom_binary_output_port (SCM id, SCM write_proc,
+                                       SCM get_position_proc,
+                                       SCM set_position_proc, SCM close_proc) {
+  return scm_call_5 (scm_c_public_ref ("ice-9 binary-ports",
+                                       "make-custom-binary-output-port"),
+                     id, write_proc, get_position_proc, set_position_proc,
+                     close_proc);
 }
-#undef FUNC_NAME
-
 
-SCM_DEFINE (scm_make_custom_binary_output_port,
-           "make-custom-binary-output-port", 5, 0, 0,
-           (SCM id, SCM write_proc, SCM get_position_proc,
-            SCM set_position_proc, SCM close_proc),
-           "Return a new custom binary output port whose output is drained "
-           "by invoking @var{write_proc} and passing it a bytevector, an "
-           "index where octets should be written, and an octet count.")
-#define FUNC_NAME s_scm_make_custom_binary_output_port
-{
-  SCM_VALIDATE_STRING (1, id);
-  SCM_VALIDATE_PROC (2, write_proc);
-
-  if (!scm_is_false (get_position_proc))
-    SCM_VALIDATE_PROC (3, get_position_proc);
-
-  if (!scm_is_false (set_position_proc))
-    SCM_VALIDATE_PROC (4, set_position_proc);
-
-  if (!scm_is_false (close_proc))
-    SCM_VALIDATE_PROC (5, close_proc);
-
-  return make_custom_binary_output_port (write_proc, get_position_proc,
-                                         set_position_proc, close_proc);
-}
-#undef FUNC_NAME
-
-
-/* Instantiate the custom binary output port type.  */
-static inline void
-initialize_custom_binary_output_ports (void)
-{
-  custom_binary_output_port_type =
-    scm_make_port_type ("r6rs-custom-binary-output-port",
-                       NULL, custom_binary_output_port_write);
-
-  scm_set_port_seek (custom_binary_output_port_type, custom_binary_port_seek);
-  scm_set_port_random_access_p (custom_binary_output_port_type,
-                                custom_binary_port_random_access_p);
-  scm_set_port_close (custom_binary_output_port_type, 
custom_binary_port_close);
-}
-
-
-
-
-/* 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
-
-
-/* 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_port_random_access_p);
-  scm_set_port_close (custom_binary_input_output_port_type,
-                      custom_binary_port_close);
+SCM scm_make_custom_binary_input_output_port (SCM id, SCM read_proc,
+                                              SCM write_proc,
+                                              SCM get_position_proc,
+                                              SCM set_position_proc,
+                                              SCM close_proc) {
+  return scm_call_6 (scm_c_public_ref ("ice-9 binary-ports",
+                                       "make-custom-binary-input/output-port"),
+                     id, read_proc, write_proc, get_position_proc,
+                     set_position_proc, close_proc);
 }
 
 
@@ -1234,10 +928,7 @@ scm_register_r6rs_ports (void)
                            NULL);
 
   initialize_bytevector_input_ports ();
-  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 56a535e8e..7b0c17768 100644
--- a/libguile/r6rs-ports.h
+++ b/libguile/r6rs-ports.h
@@ -1,7 +1,7 @@
 #ifndef SCM_R6RS_PORTS_H
 #define SCM_R6RS_PORTS_H
 
-/* Copyright 2009-2011,2013,2018-2019
+/* Copyright 2009-2011,2013,2018-2019,2023
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -28,7 +28,6 @@
 
 SCM_API SCM scm_eof_object (void);
 SCM_API SCM scm_open_bytevector_input_port (SCM, SCM);
-SCM_API SCM scm_make_custom_binary_input_port (SCM, SCM, SCM, SCM, SCM);
 SCM_API SCM scm_get_u8 (SCM);
 SCM_API SCM scm_lookahead_u8 (SCM);
 SCM_API SCM scm_get_bytevector_n (SCM, SCM);
@@ -38,9 +37,12 @@ SCM_API SCM scm_get_bytevector_all (SCM);
 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_input_port (SCM, SCM, SCM, SCM, 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 bffd74e14..b7eddc93d 100644
--- a/module/ice-9/binary-ports.scm
+++ b/module/ice-9/binary-ports.scm
@@ -1,5 +1,5 @@
 ;;; binary-ports.scm --- Binary IO on ports
-;;; Copyright (C) 2009-2011,2013,2016,2019,2021 Free Software Foundation, Inc.
+;;; Copyright (C) 2009-2011,2013,2016,2019,2021,2023 Free Software Foundation, 
Inc.
 ;;;
 ;;; This library is free software: you can redistribute it and/or modify
 ;;; it under the terms of the GNU Lesser General Public License as
@@ -27,9 +27,11 @@
 
 (define-module (ice-9 binary-ports)
   #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 custom-ports)
   #:export (eof-object
             open-bytevector-input-port
-            make-custom-binary-input-port
+            open-bytevector-output-port
             get-u8
             lookahead-u8
             get-bytevector-n
@@ -41,7 +43,7 @@
             put-u8
             put-bytevector
             unget-bytevector
-            open-bytevector-output-port
+            make-custom-binary-input-port
             make-custom-binary-output-port
             make-custom-binary-input/output-port
             call-with-input-bytevector
@@ -71,3 +73,110 @@ bytevector composed of the bytes written into the port is 
returned."
       (let ((bv (get-bytevector)))
         (close-port port)
         bv))))
+
+(define (type-error proc expecting val)
+  (scm-error 'wrong-type-arg proc "Wrong type (expecting `~S'): ~S"
+             (list expecting val) (list val)))
+
+(define (custom-binary-port-read read)
+  (unless (procedure? read)
+    (type-error "custom-binary-port-read" "procedure" read))
+  (lambda (port bv start count)
+    (let ((ret (read bv start count)))
+      (unless (and (exact-integer? ret) (<= 0 ret count))
+        (scm-error 'out-of-range "custom-binary-port-read"
+                   "Value out of range: ~S" (list ret) (list ret)))
+      ret)))
+
+(define (custom-binary-port-write write)
+  (unless (procedure? write)
+    (type-error "custom-binary-port-write" "procedure" write))
+  (lambda (port bv start count)
+    (let ((ret (write bv start count)))
+      (unless (and (exact-integer? ret) (<= 0 ret count))
+        (scm-error 'out-of-range "custom-binary-port-write"
+                   "Value out of range: ~S" (list ret) (list ret)))
+      ret)))
+
+(define (custom-binary-port-seek get-position set-position!)
+  (when get-position
+    (unless (procedure? get-position)
+      (type-error "custom-binary-port-seek" "procedure" get-position)))
+  (when set-position!
+    (unless (procedure? set-position!)
+      (type-error "custom-binary-port-seek" "procedure" set-position!)))
+
+  (define (seek port offset whence)
+    (cond
+     ((eqv? whence SEEK_CUR)
+      (unless get-position
+        (type-error "custom-binary-port-seek"
+                    "R6RS custom binary port with `port-position` support"
+                    port))
+      (if (zero? offset)
+          (get-position)
+          (seek port (+ (get-position) offset) SEEK_SET)))
+     ((eqv? whence SEEK_SET)
+      (unless set-position!
+        (type-error "custom-binary-port-seek"
+                    "Seekable R6RS custom binary port"
+                    port))
+      (set-position! offset)
+      ;; Assume setting the position succeeds.
+      offset)
+     ((eqv? whence SEEK_END)
+      (error "R6RS custom binary ports do not support `SEEK_END'"))))
+  seek)
+
+(define (custom-binary-port-close close)
+  (match close
+    (#f (lambda (port) #t))
+    ((? procedure?) (lambda (port) (close)))
+    (_ (type-error "custom-binary-port-close" "procedure" close))))
+
+(define (custom-binary-port-random-access? set-position!)
+  (if set-position!
+      (lambda (port) #t)
+      (lambda (port) #f)))
+
+(define (make-custom-binary-input-port id read get-position set-position! 
close)
+  (unless (string? id)
+    (type-error "make-custom-binary-input-port" "string" id))
+  (make-custom-port #:id id
+                    #:read (custom-binary-port-read read)
+                    #:seek (custom-binary-port-seek get-position set-position!)
+                    #:close (custom-binary-port-close close)
+                    #:random-access?
+                    (custom-binary-port-random-access? set-position!)
+                    ;; FIXME: Instead default to current encoding, if
+                    ;; someone reads text from this port.
+                    #:encoding 'ISO-8859-1 #:conversion-strategy 'error))
+
+(define (make-custom-binary-output-port id write get-position set-position!
+                                        close)
+  (unless (string? id)
+    (type-error "make-custom-binary-output-port" "string" id))
+  (make-custom-port #:id id
+                    #:write (custom-binary-port-write write)
+                    #:seek (custom-binary-port-seek get-position set-position!)
+                    #:close (custom-binary-port-close close)
+                    #:random-access?
+                    (custom-binary-port-random-access? set-position!)
+                    ;; FIXME: Instead default to current encoding, if
+                    ;; someone reads text from this port.
+                    #:encoding 'ISO-8859-1 #:conversion-strategy 'error))
+
+(define (make-custom-binary-input/output-port id read write get-position
+                                              set-position! close)
+  (unless (string? id)
+    (type-error "make-custom-binary-input/output-port" "string" id))
+  (make-custom-port #:id id
+                    #:read (custom-binary-port-read read)
+                    #:write (custom-binary-port-write write)
+                    #:seek (custom-binary-port-seek get-position set-position!)
+                    #:close (custom-binary-port-close close)
+                    #:random-access?
+                    (custom-binary-port-random-access? set-position!)
+                    ;; FIXME: Instead default to current encoding, if
+                    ;; someone reads text from this port.
+                    #:encoding 'ISO-8859-1 #:conversion-strategy 'error))