lloda pushed a commit to branch main
in repository guile.
commit ee9df40d64749c0e19b14856bc9e25df656bca34
Author: Rob Browning <[email protected]>
AuthorDate: Thu Apr 10 15:35:27 2025 -0500
make-bytestring(!): only allocate once and and write directly
Change make-bytestring! to write the parts directly to the result rather
than by way of a bytevector port. Rewrite make-bytestring to compute the
result length first so it can immediately allocate the result and then
fill it in via the new make-bytestring!
* module/srfi/srfi-207.scm: add new make-bytestring and make-bytestring!
* module/srfi/srfi-207/upstream/bytestrings-impl.scm: remove
make-bytestring and make-bytestring!
---
module/srfi/srfi-207.scm | 42 ++++++++++++++++++++--
module/srfi/srfi-207/upstream/bytestrings-impl.scm | 14 --------
2 files changed, 40 insertions(+), 16 deletions(-)
diff --git a/module/srfi/srfi-207.scm b/module/srfi/srfi-207.scm
index b77016f3c..42a42fa97 100644
--- a/module/srfi/srfi-207.scm
+++ b/module/srfi/srfi-207.scm
@@ -30,8 +30,7 @@
make-exception-with-irritants))
#:use-module ((rnrs arithmetic bitwise) #:select (bitwise-and bitwise-ior))
#:use-module ((rnrs bytevectors)
- #:select (bytevector->u8-list u8-list->bytevector))
- #:use-module ((rnrs io ports) #:select (string->bytevector))
+ #:select (bytevector->u8-list string->utf8
u8-list->bytevector))
#:use-module ((scheme base)
#:select (binary-port?
bytevector
@@ -105,6 +104,45 @@
(include-from-path "srfi/srfi-207/upstream/base64.scm")
(include-from-path "srfi/srfi-207/upstream/bytestrings-impl.scm")
+(define (make-bytestring! bvec at parts)
+ (let lp ((parts parts)
+ (i at))
+ (unless (null? parts)
+ (let ((x (car parts)))
+ (cond
+ ((and (exact-natural? x) (< x 256))
+ (bytevector-u8-set! bvec i x)
+ (lp (cdr parts) (1+ i)))
+ ((and (char? x) (char<=? x #\delete))
+ (bytevector-u8-set! bvec i (char->integer x))
+ (lp (cdr parts) (1+ i)))
+ ((bytevector? x)
+ (bytevector-copy! bvec i x 0 (bytevector-length x))
+ (lp (cdr parts) (+ i (bytevector-length x))))
+ ((string? x)
+ (let ((n (string-length x))
+ (utf8 (string->utf8 x)))
+ (unless (= n (bytevector-length utf8))
+ (bytestring-error "bytestring string part is not ASCII" x))
+ (bytevector-copy! bvec i utf8 0 n)
+ (lp (cdr parts) (+ i (string-length x)))))
+ (else
+ (bytestring-error "invalid bytestring string part" x)))))))
+
+(define (make-bytestring parts)
+ (define (byte-len x)
+ (cond
+ ((and (integer? x) (<= 0 x 255)) 1)
+ ((and (char? x) (char<=? #\delete)) 1)
+ ((bytevector? x) (bytevector-length x))
+ ((and (string? x) (string-every char-set:ascii x)) (string-length x))
+ (else (bytestring-error "invalid bytestring argument" x))))
+ (let* ((n (fold (λ (part total) (+ total (byte-len part)))
+ 0 parts))
+ (result (make-bytevector n)))
+ (make-bytestring! result 0 parts)
+ result))
+
(define (read-bytestring-content port)
;; Must use port, not (peek)/(next).
(let ((ch (read-char port)))
diff --git a/module/srfi/srfi-207/upstream/bytestrings-impl.scm
b/module/srfi/srfi-207/upstream/bytestrings-impl.scm
index fb8908b60..f91fbd726 100644
--- a/module/srfi/srfi-207/upstream/bytestrings-impl.scm
+++ b/module/srfi/srfi-207/upstream/bytestrings-impl.scm
@@ -51,20 +51,6 @@
;;;; Constructors
-(define (make-bytestring lis)
- (assume (or (pair? lis) (null? lis)))
- (call-with-port
- (open-output-bytevector)
- (lambda (out)
- (for-each (lambda (seg) (%write-bytestring-segment seg out)) lis)
- (get-output-bytevector out))))
-
-(define (make-bytestring! bvec at lis)
- (assume (bytevector? bvec))
- (assume (and (exact-natural? at)
- (< at (bytevector-length bvec))))
- (bytevector-copy! bvec at (make-bytestring lis)))
-
(define (%write-bytestring-segment obj port)
((cond ((and (exact-natural? obj) (< obj 256)) write-u8)
((and (char? obj) (char<=? obj #\delete)) write-char-binary)
