lloda pushed a commit to branch main
in repository guile.
commit b677d172a0406e06ff24df6cf884deaf53a12483
Author: Rob Browning <[email protected]>
AuthorDate: Wed Sep 10 23:02:17 2025 -0500
bytestring-join: create result via a single bytevector-append
Instead of building the result with an output bytector port which does
doubling reallocation (see bytevector_output_port_buffer_grow), build a
list of fragments via append-map! and allocate the final bytevector once
with bytevector-append.
* module/srfi/srfi-207.scm (bytestring-join): Add bytestring-append
based version.
* module/srfi/srfi-207/upstream/bytestrings-impl.scm (bytestring-join):
move to srfi-207.scm.
(%bytestring-join-nonempty): Remove.
---
module/srfi/srfi-207.scm | 28 +++++++++++++++++++--
module/srfi/srfi-207/upstream/bytestrings-impl.scm | 29 +---------------------
2 files changed, 27 insertions(+), 30 deletions(-)
diff --git a/module/srfi/srfi-207.scm b/module/srfi/srfi-207.scm
index d4fabb097..b9c7bdc45 100644
--- a/module/srfi/srfi-207.scm
+++ b/module/srfi/srfi-207.scm
@@ -32,7 +32,8 @@
string->utf8
u8-list->bytevector))
#:use-module ((scheme base)
- #:select (binary-port?
+ #:select (bytevector-append
+ binary-port?
bytevector
bytevector-copy
bytevector-copy!
@@ -52,7 +53,7 @@
write-string
write-u8))
#:use-module ((srfi srfi-1)
- #:select (fold list-tabulate fold-right unfold unfold-right))
+ #:select (append-map! circular-list fold list-tabulate unfold))
#:use-module ((srfi srfi-43) #:select (vector-unfold))
#:use-module ((srfi srfi-60) #:select (arithmetic-shift bit-field))
#:export (base64->bytevector
@@ -211,6 +212,29 @@
(integer->hex-char (logand b #x0f))
result)))))))
+(define bytestring-join
+ (case-lambda
+ ((bstrings delimiter) (bytestring-join bstrings delimiter 'infix))
+ ((bstrings delimiter grammar)
+ (assume (or (pair? bstrings) (null? bstrings)))
+ (let ((delim-bv (bytestring delimiter)))
+ (define (alternate! l1 l2) (append-map! list l1 l2))
+ (define (infix-join)
+ (if (or (null? bstrings) (null? (cdr bstrings)))
+ bstrings
+ (cons (car bstrings)
+ (alternate! (circular-list delim-bv) (cdr bstrings)))))
+ (apply bytevector-append
+ (case grammar
+ ((infix) (infix-join))
+ ((prefix) (alternate! (circular-list delim-bv) bstrings))
+ ((suffix) (alternate! bstrings (circular-list delim-bv)))
+ ((strict-infix)
+ (when (null? bstrings)
+ (bytestring-error "empty list with strict-infix grammar"))
+ (infix-join))
+ (else (bytestring-error "invalid grammar" grammar))))))))
+
(define read-textual-bytestring
(case-lambda
((prefix) (read-textual-bytestring prefix (current-input-port)))
diff --git a/module/srfi/srfi-207/upstream/bytestrings-impl.scm
b/module/srfi/srfi-207/upstream/bytestrings-impl.scm
index aab3b0c46..39ef0f14b 100644
--- a/module/srfi/srfi-207/upstream/bytestrings-impl.scm
+++ b/module/srfi/srfi-207/upstream/bytestrings-impl.scm
@@ -348,34 +348,7 @@ bytestring-error? is raised."
(bytevector-copy bstring len))))
(else (values (bytevector-copy bstring) (bytevector)))))
-;;;; Joining & Splitting
-
-(define (%bytestring-join-nonempty bstrings delimiter grammar)
- (call-with-port
- (open-output-bytevector)
- (lambda (out)
- (when (eq? grammar 'prefix) (write-bytevector delimiter out))
- (write-bytevector (car bstrings) out)
- (for-each (lambda (bstr)
- (write-bytevector delimiter out)
- (write-bytevector bstr out))
- (cdr bstrings))
- (when (eq? grammar 'suffix) (write-bytevector delimiter out))
- (get-output-bytevector out))))
-
-(define bytestring-join
- (case-lambda
- ((bstrings delimiter) (bytestring-join bstrings delimiter 'infix))
- ((bstrings delimiter grammar)
- (assume (or (pair? bstrings) (null? bstrings)))
- (unless (memv grammar '(infix strict-infix prefix suffix))
- (bytestring-error "invalid grammar" grammar))
- (let ((delim-bstring (bytestring delimiter)))
- (if (pair? bstrings)
- (%bytestring-join-nonempty bstrings delim-bstring grammar)
- (if (eq? grammar 'strict-infix)
- (bytestring-error "empty list with strict-infix grammar")
- (bytevector)))))))
+;;;; Splitting
(define (%find-right bstring byte end)
(bytestring-index-right bstring (lambda (b) (= b byte)) 0 end))
