[Guile-commits] branch main updated: Rewrite ‘get-bytevector-all’ in Scheme.

[Ludovic Courtès]

This is an automated email from the git hooks/post-receive script.

civodul pushed a commit to branch main
in repository guile.

The following commit(s) were added to refs/heads/main by this push:
     new 461ff313f Rewrite ‘get-bytevector-all’ in Scheme.
461ff313f is described below

commit 461ff313fa478d207a7668595e9d976a2ace9770
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sun Jun 16 15:01:49 2024 +0200

    Rewrite ‘get-bytevector-all’ in Scheme.
    
    * libguile/r6rs-ports.c (get_bytevector_all_var): New variable.
    (init_bytevector_io_vars): New function.
    (scm_get_bytevector_all): Rewrite as a proxy to ‘get-bytevector-all’
    from (ice-9 binary-port).
    * module/ice-9/binary-ports.scm (get-bytevector-all): New procedure.
    * NEWS: Update.
    
    Reported-by: Christopher Baines <mail@cbaines.net>
---
 NEWS                          |  7 +++++
 libguile/r6rs-ports.c         | 63 ++++++++++---------------------------------
 module/ice-9/binary-ports.scm | 29 +++++++++++++++++++-
 3 files changed, 49 insertions(+), 50 deletions(-)

diff --git a/NEWS b/NEWS
index 088c2178b..2b2ea00f5 100644
--- a/NEWS
+++ b/NEWS
@@ -48,6 +48,13 @@ files.  See "Random Access" in the manual for details.
 
 A list of superclasses can now be provided via #:super.
 
+** 'get-bytevector-all' is now written in Scheme and is thus suspendable
+
+The 'get-bytevector-all' procedure from (rnrs io ports) and (ice-9
+binary-port) used to be implemented in C, making it non-suspendable--a
+bummer for programs using suspendable ports and Fibers.  It has been
+rewritten in Scheme, addressing this limitation.
+
 * Bug fixes
 
 ** Fix incorrect comparison between exact and inexact numbers
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
index 7c51bf617..ffa1e1b2b 100644
--- a/libguile/r6rs-ports.c
+++ b/libguile/r6rs-ports.c
@@ -1,4 +1,4 @@
-/* Copyright 2009-2011,2013-2015,2018-2019,2023
+/* Copyright 2009-2011,2013-2015,2018-2019,2023,2024
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -393,58 +393,23 @@ SCM_DEFINE (scm_get_bytevector_some_x, 
"get-bytevector-some!", 4, 0, 0,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0,
-           (SCM port),
-           "Read from @var{port}, blocking as necessary, until "
-           "the end-of-file is reached.  Return either "
-           "a new bytevector containing the data read or the "
-           "end-of-file object (if no data were available).")
-#define FUNC_NAME s_scm_get_bytevector_all
-{
-  SCM result;
-  size_t c_len, c_count;
-  size_t c_read, c_total;
-
-  SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+static SCM get_bytevector_all_var;
 
-  c_len = c_count = 4096;
-  result = scm_c_make_bytevector (c_count);
-  c_total = c_read = 0;
-
-  do
-    {
-      if (c_read > c_len - c_total)
-       {
-         /* Grow the bytevector.  */
-          SCM prev = result;
-
-          if (INT_ADD_OVERFLOW (c_len, c_len))
-            scm_num_overflow (FUNC_NAME);
-
-          result = scm_c_make_bytevector (c_len * 2);
-          memcpy (SCM_BYTEVECTOR_CONTENTS (result),
-                  SCM_BYTEVECTOR_CONTENTS (prev),
-                  c_total);
-         c_count = c_len;
-         c_len *= 2;
-       }
-
-      /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
-        reached.  */
-      c_read = scm_c_read_bytes (port, result, c_total, c_count);
-      c_total += c_read, c_count -= c_read;
-    }
-  while (c_count == 0);
-
-  if (c_total == 0)
-    return SCM_EOF_VAL;
+static void
+init_bytevector_io_vars (void)
+{
+  get_bytevector_all_var =
+    scm_c_public_lookup ("ice-9 binary-port", "get-bytevector-all");
+}
 
-  if (c_len > c_total)
-    return scm_c_shrink_bytevector (result, c_total);
+SCM
+scm_get_bytevector_all (SCM port)
+{
+  static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+  scm_i_pthread_once (&once, init_bytevector_io_vars);
 
-  return result;
+  return scm_call_1 (scm_variable_ref (get_bytevector_all_var), port);
 }
-#undef FUNC_NAME
 
 
 
diff --git a/module/ice-9/binary-ports.scm b/module/ice-9/binary-ports.scm
index b7eddc93d..864d9ef9a 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,2023 Free Software Foundation, 
Inc.
+;;; Copyright (C) 2009-2011,2013,2016,2019,2021,2023,2024 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,6 +27,7 @@
 
 (define-module (ice-9 binary-ports)
   #:use-module (rnrs bytevectors)
+  #:autoload   (rnrs bytevectors gnu) (bytevector-slice)
   #:use-module (ice-9 match)
   #:use-module (ice-9 custom-ports)
   #:export (eof-object
@@ -180,3 +181,29 @@ bytevector composed of the bytes written into the port is 
returned."
                     ;; FIXME: Instead default to current encoding, if
                     ;; someone reads text from this port.
                     #:encoding 'ISO-8859-1 #:conversion-strategy 'error))
+
+
+;;;
+;;; Binary input.
+;;;
+
+(define (get-bytevector-all port)
+  "Read from @var{port}, blocking as necessary, until
+the end-of-file is reached.  Return either a new bytevector containing
+the data read or the end-of-file object (if no data were available)."
+  (define initial-capacity 4096)
+
+  (let loop ((bv (make-bytevector initial-capacity))
+             (capacity initial-capacity)
+             (size 0))
+    (match (get-bytevector-n! port bv size (- capacity size))
+      ((? eof-object?)
+       (bytevector-slice bv 0 size))
+      (read
+       (let ((size (+ read size)))
+         (if (= capacity size)
+             (let* ((capacity (* capacity 2))
+                    (new (make-bytevector capacity)))
+               (bytevector-copy! bv 0 new 0 size)
+               (loop new capacity size))
+             (loop bv capacity size)))))))