diff --git a/NEWS b/NEWS index 121ad0b8e..7789d5929 100644 --- a/NEWS +++ b/NEWS @@ -65,6 +65,13 @@ IPv6 support; they can be used with `bind'. Likewise, the `IPPROTO_IPV6' and `IPV6_V6ONLY' constants are defined, for use with `setsockopt'. +** New `bytevector-slice' procedure + +As an extension to the R6RS interface, the new (rnrs bytevectors gnu) +module defines `bytevector-slice', which returns a bytevector that +aliases part of an existing bytevector. See "Bytevector Slices" in the +manual. + ** Disassembler now shows intrinsic names Disassembler output now includes the name of intrinsics next to each 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 30190f315..d332aa997 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..6d9f6476d 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -1,4 +1,4 @@ -/* Copyright 2009-2015,2018-2019 +/* Copyright 2009-2015,2018-2019,2023 Free Software Foundation, Inc. This file is part of Guile. @@ -24,6 +24,7 @@ #include #include +#include #include #include #include @@ -325,6 +326,66 @@ 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); + + 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 (INT_ADD_OVERFLOW (c_offset, c_size) + || (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..593c94859 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, 2023 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..3258dfd17 --- /dev/null +++ b/module/rnrs/bytevectors/gnu.scm @@ -0,0 +1,24 @@ +;;;; gnu.scm --- GNU extensions to the bytevector API. + +;;;; Copyright (C) 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 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..504910202 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,8 @@ #:use-module (test-suite lib) #:use-module (system base compile) #:use-module (rnrs bytevectors) + #:use-module (rnrs bytevectors gnu) + #:use-module ((system foreign) #:select (sizeof size_t)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-4)) @@ -666,6 +668,69 @@ 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-exception "size + offset overflows" + exception:out-of-range + (let ((size_t-max (expt 2 (* 8 (sizeof size_t))))) + ;; Without overflow checks, this would read arbitrary memory. + (bytevector-slice #vu8(1 2 3) (- size_t-max 10) 10))) + + (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 offset for f32vector" + 10 + (let* ((v #f32(1.1 1.2 3.14)) + (s (bytevector-slice v 2))) + (and (not (f32vector? s)) + (bytevector-length s)))) + + (pass-if-equal "unaligned size for f32vector" + 1 + (let* ((v #f32(1.1 1.2 3.14)) + (s (bytevector-slice v 0 1))) + (and (not (f32vector? s)) + (bytevector-length s))))) + (with-test-prefix "Arrays"