[Guile-commits] 08/09: DRAFT Add 'bytevector-slice'.

[Ludovic Courtès]

civodul pushed a commit to branch wip-linker-assembler-memory-consumption
in repository guile.

commit 8c8d4bd376e241056a62f6bff67c51787d61f56f
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri Jan 6 17:46:06 2023 +0100

    DRAFT Add 'bytevector-slice'.
    
    TODO: Add doc.
    
    * 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.
---
 am/bootstrap.am                   |  1 +
 libguile/bytevectors.c            | 39 ++++++++++++++++++++++++++++++++++++++-
 libguile/bytevectors.h            |  3 ++-
 module/rnrs/bytevectors/gnu.scm   | 24 ++++++++++++++++++++++++
 test-suite/tests/bytevectors.test | 20 +++++++++++++++++++-
 5 files changed, 84 insertions(+), 3 deletions(-)

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/libguile/bytevectors.c b/libguile/bytevectors.c
index bbc23f449..120e248a4 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -1,4 +1,4 @@
-/* Copyright 2009-2015,2018-2019
+/* Copyright 2009-2015,2018-2019,2022
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -325,6 +325,43 @@ 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 "
+            "@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.")
+#define FUNC_NAME s_scm_bytevector_slice
+{
+  SCM ret;
+  size_t c_offset, c_size;
+
+  SCM_VALIDATE_BYTEVECTOR (1, bv);
+  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);
+
+  ret = make_bytevector_from_buffer (c_size,
+                                     SCM_BYTEVECTOR_CONTENTS (bv) + c_offset,
+                                     SCM_ARRAY_ELEMENT_TYPE_VU8);
+  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..a11c4cd85 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))
 
@@ -667,6 +668,23 @@
     (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)))))
+
 (with-test-prefix "Arrays"
 
   (pass-if "array?"