~ chicken-core (master) 21475339a0fc3ed9f488acf1495b1ba34254d9e4
commit 21475339a0fc3ed9f488acf1495b1ba34254d9e4
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Apr 8 15:52:48 2026 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Apr 8 15:52:48 2026 +0200
provide and use variant of ##sys#buffer->string that reuses and shortens the given buffer
diff --git a/c-platform.scm b/c-platform.scm
index d4650f09..3e7dc34b 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -281,7 +281,7 @@
##sys#foreign-ranged-integer-argument ##sys#foreign-unsigned-ranged-integer-argument
##sys#peek-fixnum ##sys#setislot ##sys#poke-integer ##sys#permanent? ##sys#values ##sys#poke-double
##sys#intern-symbol ##sys#intern-keyword ##sys#null-pointer? ##sys#peek-byte
- ##sys#foreign-symbol-argument
+ ##sys#foreign-symbol-argument ##sys#buffer->string!
##sys#symbol->string/shared ##sys#buffer->string ##sys#string->symbol-name
##sys#bytevector->list ##sys#list->bytevector ##sys#make-bytevector
##sys#file-exists? ##sys#substring-index ##sys#substring-index-ci ##sys#lcm ##sys#gcd))
diff --git a/chicken.h b/chicken.h
index f5645633..6945fcd1 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1950,6 +1950,7 @@ C_fctexport C_word C_utf_char_foldcase(C_word c) C_regparm;
C_fctexport C_word C_utf_string_foldcase(C_word from, C_word to, C_word len) C_regparm;
C_fctexport C_word C_utf_string_downcase(C_word from, C_word to, C_word len) C_regparm;
C_fctexport C_word C_utf_string_upcase(C_word from, C_word to, C_word len) C_regparm;
+C_fctexport C_word C_utf_set_bv_size(C_word bv, C_word sz) C_regparm;
#ifdef C_WCHAR_FILENAMES
C_fctexport C_WCHAR *C_utf16(C_word bv, int cont) C_regparm;
C_fctexport C_char *C_utf8(C_WCHAR *str) C_regparm;
diff --git a/library.scm b/library.scm
index 3f06ab74..f2b87fed 100644
--- a/library.scm
+++ b/library.scm
@@ -682,7 +682,7 @@ EOF
(n (##core#inline "C_fixnum_difference" (##sys#size bv) 1))
(buf (##sys#make-bytevector (##core#inline "C_fixnum_times" n 2)))
(len (##core#inline "C_utf_string_foldcase" bv buf n)))
- (##sys#buffer->string buf 0 len)))
+ (##sys#buffer->string! buf len)))
(define (string-downcase str)
(##sys#check-string str 'string-downcase)
@@ -690,7 +690,7 @@ EOF
(n (##core#inline "C_fixnum_difference" (##sys#size bv) 1))
(buf (##sys#make-bytevector (##core#inline "C_fixnum_times" n 2)))
(len (##core#inline "C_utf_string_downcase" bv buf n)))
- (##sys#buffer->string buf 0 len)))
+ (##sys#buffer->string! buf len)))
(define (string-upcase str)
(##sys#check-string str 'string-upcase)
@@ -698,7 +698,7 @@ EOF
(n (##core#inline "C_fixnum_difference" (##sys#size bv) 1))
(buf (##sys#make-bytevector (##core#inline "C_fixnum_times" n 2)))
(len (##core#inline "C_utf_string_upcase" bv buf n)))
- (##sys#buffer->string buf 0 len)))
+ (##sys#buffer->string! buf len)))
;;; Procedures:
@@ -1677,6 +1677,11 @@ EOF
(##core#inline "C_utf_fill" bv fill)
(##core#inline_allocate ("C_a_ustring" 5) bv size)))
+(define (##sys#buffer->string! buf len)
+ (##core#inline "C_utf_set_bv_size" buf len)
+ (##core#inline_allocate ("C_a_ustring" 5) buf
+ (##core#inline "C_utf_range_length" buf 0 len)))
+
(define (##sys#buffer->string buf start len)
(let ((bv (##sys#make-bytevector (fx+ len 1))))
(##core#inline "C_copy_memory_with_offset" bv buf 0 start len)
@@ -3500,7 +3505,7 @@ EOF
(let* ((len (##sys#size bv))
(buf (##sys#make-bytevector (##core#inline "C_fixnum_times" len 2)))
(n (##core#inline "C_latin_to_utf" bv buf 0 len)))
- (##sys#buffer->string buf 0 n)))
+ (##sys#buffer->string! buf n)))
(define (bytevector=? b1 b2)
(##sys#check-bytevector b1 'bytevector=?)
@@ -6579,7 +6584,7 @@ EOF
(let* ([len (##core#inline "C_fetch_c_strlen" b i)]
[bv (##sys#make-bytevector (fx+ len 1) 0)] )
(##core#inline "C_peek_c_string" b i bv len)
- (##sys#buffer->string bv 0 len)))
+ (##sys#buffer->string! bv len)))
(define (##sys#peek-and-free-c-string b i)
(let ((str (##sys#peek-c-string b i)))
@@ -7825,7 +7830,7 @@ static C_word C_curdir(C_word buf, C_word size) {
(let loop ((i 0)
(p start))
(if (fx= p end)
- (##sys#buffer->string bv 0 i)
+ (##sys#buffer->string! bv i)
(let ((c (##sys#slot v p)))
(##sys#check-char c 'vector->string)
(loop (##core#inline "C_utf_insert" bv i c)
@@ -7842,7 +7847,7 @@ static C_word C_curdir(C_word buf, C_word size) {
(let loop ((i 0)
(j 0))
(if (fx>= j len)
- (##sys#buffer->string ans 0 i)
+ (##sys#buffer->string! ans i)
(let ((r (proc (string-ref s j))))
(##sys#check-char r 'string-map)
(loop (##core#inline "C_utf_insert" ans i r)
diff --git a/posixunix.scm b/posixunix.scm
index 083cc57f..bb598c89 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -755,7 +755,7 @@ static int set_file_mtime(C_word filename, C_word atime, C_word mtime)
buf)))
(if (fx< len 0)
(posix-error #:file-error location "cannot read symbolic link" fname)
- (##sys#buffer->string buf 0 len))))))
+ (##sys#buffer->string! buf len))))))
(set! chicken.file.posix#read-symbolic-link
(lambda (fname #!optional canonicalize)
diff --git a/utf.c b/utf.c
index aaf7578a..19b317f4 100644
--- a/utf.c
+++ b/utf.c
@@ -3360,6 +3360,15 @@ C_regparm C_word C_utf_overwrite(C_word s, C_word i, C_word len, C_word bv,
return C_SCHEME_UNDEFINED;
}
+C_regparm C_word C_utf_set_bv_size(C_word bv, C_word sz)
+{
+ int i = C_unfix(sz);
+ C_block_header_init(bv, C_make_header(C_BYTEVECTOR_TYPE, i + 1));
+ C_char *p = (C_char *)C_data_pointer(bv);
+ p[ i ] = 0;
+ return bv;
+}
+
C_regparm C_word C_utf_compare(C_word s1, C_word s2, C_word start1, C_word start2,
C_word len)
{
Trap