[PATCH] Add 'bytevector-slice'.

[Ludovic Courtès]

* module/rnrs/bytevectors/gnu.scm: New file.
* am/bootstrap.am (SOURCES): Add it.
* libguile/bytevectors.c (scm_bytevector_slice): New function.
* libguile/bytevectors.h (scm_bytevector_slice): New declaration.
* test-suite/tests/bytevectors.test ("bytevector-slice"): New tests.
* doc/ref/api-data.texi (Bytevector Slices): New node.
---
 am/bootstrap.am                   |  1 +
 doc/ref/api-data.texi             | 46 ++++++++++++++++++++-
 doc/ref/guile.texi                |  2 +-
 libguile/bytevectors.c            | 69 ++++++++++++++++++++++++++++++-
 libguile/bytevectors.h            |  3 +-
 module/rnrs/bytevectors/gnu.scm   | 24 +++++++++++
 test-suite/tests/bytevectors.test | 53 +++++++++++++++++++++++-
 7 files changed, 193 insertions(+), 5 deletions(-)
 create mode 100644 module/rnrs/bytevectors/gnu.scm

Hello!

This is an updated version of the ‘bytevector-slice’ primitive I used in
the linker/assembler patch series¹ that I think is ready to go.

I went to some length to do something sensible wrt. element type of the
input, when the input is a SRFI-4 uniform vector.  The other option would
be to make the output a pure bytevector unconditionally, but I thought
it would be more consistent and useful to preserve the input element type
when possible (see tests with an f32vector).

If there are no objections, I’ll push it to ‘main’ in the coming days.

Thanks,
Ludo’.

¹ https://lists.gnu.org/archive/html/guile-devel/2023-01/msg00013.html

diff --git a/am/bootstrap.am b/am/bootstrap.am
index 0257d53dc..53ee68315 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -249,6 +249,7 @@ SOURCES =                                   \
   rnrs/arithmetic/fixnums.scm                  \
   rnrs/arithmetic/flonums.scm                  \
   rnrs/bytevectors.scm                         \
+  rnrs/bytevectors/gnu.scm                     \
   rnrs/io/simple.scm                           \
   rnrs/io/ports.scm                            \
   rnrs/records/inspection.scm                  \
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 8658b9785..fe2d2af50 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C)  1996, 1997, 2000-2004, 2006-2017, 2019-2020, 2022
+@c Copyright (C)  1996, 1997, 2000-2004, 2006-2017, 2019-2020, 2022-2023
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -6673,6 +6673,7 @@ Bytevectors can be used with the binary input/output 
primitives
 * Bytevectors as Strings::      Interpreting bytes as Unicode strings.
 * Bytevectors as Arrays::       Guile extension to the bytevector API.
 * Bytevectors as Uniform Vectors::  Bytevectors and SRFI-4.
+* Bytevector Slices::           Aliases for parts of a bytevector.
 @end menu
 
 @node Bytevector Endianness
@@ -7108,6 +7109,49 @@ Bytevectors may also be accessed with the SRFI-4 API. 
@xref{SRFI-4 and
 Bytevectors}, for more information.
 
 
+@node Bytevector Slices
+@subsubsection Bytevector Slices
+
+@cindex subset, of a bytevector
+@cindex slice, of a bytevector
+@cindex slice, of a uniform vector
+As an extension to the R6RS specification, the @code{(rnrs bytevectors
+gnu)} module provides the @code{bytevector-slice} procedure, which
+returns a bytevector aliasing part of an existing bytevector.
+
+@deffn {Scheme Procedure} bytevector-slice @var{bv} @var{offset} [@var{size}]
+@deffnx {C Function} scm_bytevector_slice (@var{bv}, @var{offset}, @var{size})
+Return the slice of @var{bv} starting at @var{offset} and counting
+@var{size} bytes.  When @var{size} is omitted, the slice covers all
+of @var{bv} starting from @var{offset}.  The returned slice shares
+storage with @var{bv}: changes to the slice are visible in @var{bv}
+and vice-versa.
+
+When @var{bv} is actually a SRFI-4 uniform vector, its element
+type is preserved unless @var{offset} and @var{size} are not aligned
+on its element type size.
+@end deffn
+
+Here is an example showing how to use it:
+
+@lisp
+(use-modules (rnrs bytevectors)
+             (rnrs bytevectors gnu))
+
+(define bv (u8-list->bytevector (iota 10)))
+(define slice (bytevector-slice bv 2 3))
+
+slice
+@result{} #vu8(2 3 4)
+
+(bytevector-u8-set! slice 0 77)
+slice
+@result{} #vu8(77 3 4)
+
+bv
+@result{} #vu8(0 1 77 3 4 5 6 7 8 9)
+@end lisp
+
 @node Arrays
 @subsection Arrays
 @tpindex Arrays
diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index 6a81a0893..8414c3e2d 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -13,7 +13,7 @@
 @copying
 This manual documents Guile version @value{VERSION}.
 
-Copyright (C) 1996-1997, 2000-2005, 2009-2021 Free Software Foundation,
+Copyright (C) 1996-1997, 2000-2005, 2009-2023 Free Software Foundation,
 Inc. @*
 Copyright (C) 2021 Maxime Devos
 
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index bbc23f449..6b920c88a 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -1,4 +1,4 @@
-/* Copyright 2009-2015,2018-2019
+/* Copyright 2009-2015,2018-2019,2022-2023
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -325,6 +325,73 @@ scm_c_take_typed_bytevector (signed char *contents, size_t 
len,
   return ret;
 }
 
+SCM_DEFINE (scm_bytevector_slice, "bytevector-slice", 2, 1, 0,
+            (SCM bv, SCM offset, SCM size),
+            "Return the slice of @var{bv} starting at @var{offset} and 
counting\n"
+            "@var{size} bytes.  When @var{size} is omitted, the slice covers 
all\n"
+            "of @var{bv} starting from @var{offset}.  The returned slice 
shares\n"
+            "storage with @var{bv}: changes to the slice are visible in 
@var{bv}\n"
+            "and vice-versa.\n"
+            "\n"
+            "When @var{bv} is actually a SRFI-4 uniform vector, its element\n"
+            "type is preserved unless @var{offset} and @var{size} are not 
aligned\n"
+            "on its element type size.\n")
+#define FUNC_NAME s_scm_bytevector_slice
+{
+  SCM ret;
+  size_t c_offset, c_size;
+  scm_t_array_element_type element_type;
+
+  SCM_VALIDATE_BYTEVECTOR (1, bv);
+
+  /* FIXME: Until 3.0.8 included, the assembler would not set the
+     SCM_F_BYTEVECTOR_CONTIGUOUS flag on literals.  Thus, ignore it and
+     assume BV is contiguous (how could it not be anyway?).  */
+#if 0
+  if (!SCM_BYTEVECTOR_CONTIGUOUS_P (bv))
+    scm_wrong_type_arg_msg (FUNC_NAME, 0, bv, "contiguous bytevector");
+#endif
+
+  c_offset = scm_to_size_t (offset);
+
+  if (SCM_UNBNDP (size))
+    {
+      if (c_offset < SCM_BYTEVECTOR_LENGTH (bv))
+        c_size = SCM_BYTEVECTOR_LENGTH (bv) - c_offset;
+      else
+        c_size = 0;
+    }
+  else
+    c_size = scm_to_size_t (size);
+
+  if (c_offset + c_size > SCM_BYTEVECTOR_LENGTH (bv))
+    scm_out_of_range (FUNC_NAME, offset);
+
+  /* Preserve the element type of BV, unless we're not slicing on type
+     boundaries.  */
+  element_type = SCM_BYTEVECTOR_ELEMENT_TYPE (bv);
+  if ((c_offset % SCM_BYTEVECTOR_TYPE_SIZE (bv) != 0)
+      || (c_size % SCM_BYTEVECTOR_TYPE_SIZE (bv) != 0))
+    element_type = SCM_ARRAY_ELEMENT_TYPE_VU8;
+  else
+    c_size /= (scm_i_array_element_type_sizes[element_type] / 8);
+
+  ret = make_bytevector_from_buffer (c_size,
+                                     SCM_BYTEVECTOR_CONTENTS (bv) + c_offset,
+                                     element_type);
+  if (!SCM_MUTABLE_BYTEVECTOR_P (bv))
+    {
+      /* Preserve the immutability property.  */
+      scm_t_bits flags = SCM_BYTEVECTOR_FLAGS (ret);
+      SCM_SET_BYTEVECTOR_FLAGS (ret, flags | SCM_F_BYTEVECTOR_IMMUTABLE);
+    }
+
+  SCM_BYTEVECTOR_SET_PARENT (ret, bv);
+
+  return ret;
+}
+#undef FUNC_NAME
+
 /* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current
    size) and return the new bytevector (possibly different from BV).  */
 SCM
diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h
index 980d6e267..6179bfd86 100644
--- a/libguile/bytevectors.h
+++ b/libguile/bytevectors.h
@@ -1,7 +1,7 @@
 #ifndef SCM_BYTEVECTORS_H
 #define SCM_BYTEVECTORS_H
 
-/* Copyright 2009,2011,2018
+/* Copyright 2009,2011,2018,2022
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -52,6 +52,7 @@ SCM_API uint8_t scm_c_bytevector_ref (SCM, size_t);
 SCM_API void scm_c_bytevector_set_x (SCM, size_t, uint8_t);
 
 SCM_API SCM scm_make_bytevector (SCM, SCM);
+SCM_API SCM scm_bytevector_slice (SCM, SCM, SCM);
 SCM_API SCM scm_native_endianness (void);
 SCM_API SCM scm_bytevector_p (SCM);
 SCM_API SCM scm_bytevector_length (SCM);
diff --git a/module/rnrs/bytevectors/gnu.scm b/module/rnrs/bytevectors/gnu.scm
new file mode 100644
index 000000000..ce97535a8
--- /dev/null
+++ b/module/rnrs/bytevectors/gnu.scm
@@ -0,0 +1,24 @@
+;;;; gnu.scm --- GNU extensions to the bytevector API.
+
+;;;;   Copyright (C) 2022 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 published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 
USA
+
+(define-module (rnrs bytevectors gnu)
+  #:version (6)
+  #:export (bytevector-slice))
+
+(define bytevector-slice
+  (@@ (rnrs bytevectors) bytevector-slice))
diff --git a/test-suite/tests/bytevectors.test 
b/test-suite/tests/bytevectors.test
index 732aadb3e..dc4b32370 100644
--- a/test-suite/tests/bytevectors.test
+++ b/test-suite/tests/bytevectors.test
@@ -1,6 +1,6 @@
 ;;;; bytevectors.test --- R6RS bytevectors. -*- mode: scheme; coding: utf-8; 
-*-
 ;;;;
-;;;; Copyright (C) 2009-2015, 2018, 2021 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009-2015, 2018, 2021, 2023 Free Software Foundation, Inc.
 ;;;;
 ;;;; Ludovic Courtès
 ;;;;
@@ -22,6 +22,7 @@
   #:use-module (test-suite lib)
   #:use-module (system base compile)
   #:use-module (rnrs bytevectors)
+  #:use-module (rnrs bytevectors gnu)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-4))
 
@@ -666,6 +667,56 @@
     exception:out-of-range
     (with-input-from-string "#vu8(0 256)" read)))
 
+
+(with-test-prefix "bytevector-slice"
+
+  (pass-if-exception "wrong size"
+      exception:out-of-range
+    (let ((b #vu8(1 2 3)))
+      (bytevector-slice b 1 3)))
+
+  (pass-if-equal "slices"
+      (list #vu8(1 2) #vu8(2 3)
+            #vu8(1)   #vu8(2) #vu8(3))
+    (let ((b #vu8(1 2 3)))
+      (list (bytevector-slice b 0 2)
+            (bytevector-slice b 1)
+            (bytevector-slice b 0 1)
+            (bytevector-slice b 1 1)
+            (bytevector-slice b 2))))
+
+  (pass-if-exception "immutable flag preserved"
+      exception:wrong-type-arg
+    (compile '(begin
+                (use-modules (rnrs bytevectors)
+                             (rnrs bytevectors gnu))
+
+                ;; The literal bytevector below is immutable.
+                (let ((bv #vu8(1 2 3)))
+                  (bytevector-u8-set! (bytevector-slice bv 1) 0 0)))
+
+             ;; Disable optimizations to invoke the full-blown
+             ;; 'scm_bytevector_u8_set_x' procedure, which checks for
+             ;; the SCM_F_BYTEVECTOR_IMMUTABLE flag.
+             #:optimization-level 0
+             #:to 'value))
+
+  (pass-if-equal "slice of f32vector"
+      '(8 2)
+    (let* ((v #f32(1.1 1.2 3.14))
+           (s (bytevector-slice v 4)))
+      (and (= (f32vector-ref s 0)
+              (f32vector-ref v 1))
+           (list (bytevector-length s)
+                 (f32vector-length s)))))
+
+  (pass-if-equal "unaligned slice of f32vector"
+      10
+    (let* ((v #f32(1.1 1.2 3.14))
+           (s (bytevector-slice v 2)))
+      (and (not (f32vector? s))
+           (bytevector-length s)))))
+
 
 (with-test-prefix "Arrays"
 
-- 
2.38.1