~ chicken-core (master) dfc21b56436d1ce83911a66e85f90297bfee4136
commit dfc21b56436d1ce83911a66e85f90297bfee4136
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Tue Jun 30 13:22:12 2026 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Tue Jun 30 14:19:55 2026 +0200
Fix a few foreign blob allocations to use bytevectors instead of strings
With the new allocation scheme, strings are a wrapper object. The
memory allocated for these blobs would live in the wrapped bytevector,
so passing it directly as a scheme-pointer would result in an out of
bounds read or write.
Signed-off-by: felix <felix@call-with-current-continuation.org>
diff --git a/posix-common.scm b/posix-common.scm
index d4fec5ed..5b334072 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -609,7 +609,7 @@ EOF
(let ((tm-size (foreign-value "sizeof(struct tm)" int)))
(lambda (tm)
(check-time-vector 'local-time->seconds tm)
- (let ((t (##core#inline_allocate ("C_a_mktime" 7) tm (##sys#make-string tm-size #\nul))))
+ (let ((t (##core#inline_allocate ("C_a_mktime" 7) tm (##sys#make-bytevector tm-size 0))))
(if (= -1 t)
(##sys#error 'local-time->seconds "cannot convert time vector to seconds" tm)
t)))))
@@ -623,9 +623,9 @@ EOF
(if fmt
(begin
(##sys#check-string fmt 'time->string)
- (or (strftime tm (##sys#make-c-string fmt 'time->string) (##sys#make-string tm-size #\nul))
+ (or (strftime tm (##sys#make-c-string fmt 'time->string) (##sys#make-bytevector tm-size 0))
(##sys#error 'time->string "time formatting overflows buffer" tm)) )
- (let ([str (asctime tm (##sys#make-string tm-size #\nul))])
+ (let ([str (asctime tm (##sys#make-bytevector tm-size 0))])
(if str
(##sys#substring str 0 (fx- (string-length str) 1))
(##sys#error 'time->string "cannot convert time vector to string" tm) ) ) ) ) ) )
diff --git a/posixunix.scm b/posixunix.scm
index cd429f23..a9f0ebd6 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -1064,13 +1064,13 @@ static int set_file_mtime(C_word filename, C_word atime, C_word mtime)
(lambda (tim #!optional (fmt "%a %b %e %H:%M:%S %Z %Y"))
(##sys#check-string tim 'string->time)
(##sys#check-string fmt 'string->time)
- (strptime (##sys#make-c-string tim 'string->time) (##sys#make-c-string fmt) (make-vector 10 #f) (##sys#make-string tm-size #\nul)) ) ) )
+ (strptime (##sys#make-c-string tim 'string->time) (##sys#make-c-string fmt) (make-vector 10 #f) (##sys#make-bytevector tm-size 0)) ) ) )
(set! chicken.time.posix#utc-time->seconds
(let ((tm-size (foreign-value "sizeof(struct tm)" int)))
(lambda (tm)
(check-time-vector 'utc-time->seconds tm)
- (let ((t (##core#inline_allocate ("C_a_timegm" 7) tm (##sys#make-string tm-size #\nul))))
+ (let ((t (##core#inline_allocate ("C_a_timegm" 7) tm (##sys#make-bytevector tm-size 0))))
(if (= -1 t)
(##sys#error 'utc-time->seconds "cannot convert time vector to seconds" tm)
t)))))
diff --git a/posixwin.scm b/posixwin.scm
index 6415545e..673f545c 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -553,9 +553,9 @@ static int set_file_mtime(C_word filename, C_word atime, C_word mtime)
(lambda (fd size . buffer)
(##sys#check-fixnum fd 'file-read)
(##sys#check-fixnum size 'file-read)
- (let ([buf (if (pair? buffer) (car buffer) (make-string size))])
- (unless (and (##core#inline "C_blockp" buf) (##core#inline "C_byteblockp" buf))
- (##sys#signal-hook #:type-error 'file-read "bad argument type - not a string or bytevector" buf) )
+ (let ([buf (if (pair? buffer) (car buffer) (##sys#make-bytevector size))])
+ (unless (##core#inline "C_byteblockp" buf)
+ (##sys#signal-hook #:type-error 'file-read "bad argument type - not a bytevector" buf) )
(let ([n (##core#inline "C_read" fd buf size)])
(when (eq? -1 n)
(##sys#signal-hook/errno
diff --git a/tcp.scm b/tcp.scm
index 11d5f908..a20539b0 100644
--- a/tcp.scm
+++ b/tcp.scm
@@ -301,7 +301,7 @@ EOF
"addr->sin_addr.s_addr = htonl(INADDR_ANY);") )
(define (bind-socket style host port)
- (let ((addr (make-string _sockaddr_in_size)))
+ (let ((addr (##sys#make-bytevector _sockaddr_in_size)))
(if host
(unless (gethostaddr addr host port)
(##sys#signal-hook
@@ -627,7 +627,7 @@ EOF
(define (tcp-connect host #!optional port (enc 'utf-8))
(let* ((tmc (tcp-connect-timeout))
(dlc (and tmc (+ (current-process-milliseconds) tmc)))
- (addr (make-string _sockaddr_in_size)))
+ (addr (##sys#make-bytevector _sockaddr_in_size)))
(##sys#check-string host)
(unless port
(set!-values (host port) (parse-host host "tcp"))
Trap