~ chicken-core (master) baff7c8771d5240277f282156691129f59be9ed5
commit baff7c8771d5240277f282156691129f59be9ed5
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Sep 1 11:29:47 2026 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Tue Sep 1 11:29:47 2026 +0200
handle decoding and lookahead in TCP and process-ports properly.
Thanks to "crzcrz" for support, advice and testing.
diff --git a/posixunix.scm b/posixunix.scm
index b76b8808..d72e15be 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -180,6 +180,7 @@ static sigset_t C_sigset;
#define C_open(fn, fl, m) C_fix(open(C_c_string(fn), C_unfix(fl), C_unfix(m)))
#define C_read(fd, b, n) C_fix(read(C_unfix(fd), C_c_string(b), C_unfix(n)))
+#define C_read_with_offset(fd, b, o, n) C_fix(read(C_unfix(fd), C_c_string(b) + C_unfix(o), C_unfix(n)))
#define C_write(fd, b, start, n) C_fix(write(C_unfix(fd), C_c_string(b) + C_unfix(start), C_unfix(n)))
#define C_mkstemp(t) C_fix(mkstemp(C_c_string(t)))
@@ -803,53 +804,63 @@ static int set_file_mtime(C_word filename, C_word atime, C_word mtime)
(posix-error #:file-error loc "cannot select" fd nam))
(fx= 1 res))))]
[peek
- (lambda ()
- (if (fx>= bufpos buflen)
- #!eof
- (##sys#decode-buffer buf bufpos 1 (##sys#slot this-port 15)
- (lambda (buf start n)
- (##core#inline "C_utf_decode" buf start)))))]
- [fetch
- (lambda ()
- (let loop ()
- (let ([cnt (##core#inline "C_read" fd buf bufsiz)])
- (cond ((fx= cnt -1)
- (cond
- ((eagain/ewouldblock? _errno)
- (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
- (##sys#thread-yield!)
- (loop) )
- ((fx= _errno _eintr)
- (##sys#dispatch-interrupt loop))
- (else (posix-error #:file-error loc "cannot read" fd nam) )))
- [(and more? (fx= cnt 0))
- ;; When "more" keep trying, otherwise read once more
- ;; to guard against race conditions
- (if more?
- (begin
- (##sys#thread-yield!)
- (loop) )
- (let ([cnt (##core#inline "C_read" fd buf bufsiz)])
- (when (fx= cnt -1)
- (if (eagain/ewouldblock? _errno)
- (set! cnt 0)
- (posix-error #:file-error loc "cannot read" fd nam) ) )
- (set! buflen cnt)
- (set! bufpos 0) ) )]
- [else
- (set! buflen cnt)
- (set! bufpos 0)]) ) ) )] )
+ (lambda ()
+ (if (fx>= bufpos buflen)
+ #!eof
+ (let ((p bufpos))
+ (##sys#read-char/encoding
+ this-port (##sys#slot this-port 15)
+ (lambda (buf start len dec)
+ (dec buf start len
+ (lambda (buf start len)
+ (set! bufpos p)
+ (##core#inline "C_utf_decode" buf start))))))))]
+ (fetch
+ (lambda ()
+ (let loop ()
+ (let ((d (fx- buflen bufpos)))
+ (when (fx> d 0)
+ (##core#inline "C_copy_memory_with_offset" buf buf 0 bufpos d))
+ (let ((cnt (##core#inline "C_read_with_offset" fd buf d (fx- bufsiz d))))
+ (cond ((fx= cnt -1)
+ (cond
+ ((eagain/ewouldblock? _errno)
+ (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
+ (##sys#thread-yield!)
+ (loop) )
+ ((fx= _errno _eintr)
+ (##sys#dispatch-interrupt loop))
+ (else (posix-error #:file-error loc "cannot read" fd nam) )))
+ ((and more? (fx= cnt 0))
+ ;; When "more" keep trying, otherwise read once more
+ ;; to guard against race conditions
+ (if more?
+ (begin
+ (##sys#thread-yield!)
+ (loop) )
+ (let ([cnt (##core#inline "C_read_with_offset" fd buf d (fx- bufsiz d))])
+ (when (fx= cnt -1)
+ (if (eagain/ewouldblock? _errno)
+ (set! cnt 0)
+ (posix-error #:file-error loc "cannot read" fd nam) ) )
+ (set! buflen (fx+ cnt d))
+ (set! bufpos 0) ) ))
+ (else
+ (set! buflen (fx+ cnt d))
+ (set! bufpos 0))) ) )))) )
(let ([the-port
(make-input-port
(lambda () ; read-char
- (when (fx>= bufpos buflen)
+ (when (fx>= (fx+ bufpos 4) buflen)
(fetch))
(if (fx>= bufpos buflen)
#!eof
- (##sys#decode-buffer buf bufpos 1 (##sys#slot this-port 15)
- (lambda (buf start n)
- (set! bufpos (fx+ bufpos n))
- (##core#inline "C_utf_decode" buf start)))))
+ (##sys#read-char/encoding
+ this-port (##sys#slot this-port 15)
+ (lambda (buf start len dec)
+ (dec buf start len
+ (lambda (buf start len)
+ (##core#inline "C_utf_decode" buf start)))))))
(lambda () ; char-ready?
(or (fx< bufpos buflen)
(ready?)) )
@@ -859,7 +870,7 @@ static int set_file_mtime(C_word filename, C_word atime, C_word mtime)
(on-close))
peek-char:
(lambda () ; peek-char
- (when (fx>= bufpos buflen)
+ (when (fx>= (fx+ bufpos 4) buflen)
(fetch))
(peek) )
read-bytevector:
diff --git a/tcp.scm b/tcp.scm
index 91bfed1c..61f72da7 100644
--- a/tcp.scm
+++ b/tcp.scm
@@ -178,12 +178,15 @@ EOF
(define listen (foreign-lambda int "listen" int int))
(define accept (foreign-lambda int "accept" int c-pointer c-pointer))
(define close (foreign-lambda int "closesocket" int))
-(define recv (foreign-lambda int "recv" int scheme-pointer int int))
(define shutdown (foreign-lambda int "shutdown" int int))
(define connect (foreign-lambda int "connect" int scheme-pointer int))
(define check-fd-ready (foreign-lambda int "C_check_fd_ready" int))
(define set-socket-options (foreign-lambda int "C_set_socket_options" int))
+(define recv
+ (foreign-lambda* int ((int s) (scheme-pointer buf) (int offset) (int len))
+ "C_return(recv(s, (char *)buf+offset, len, 0));"))
+
(define send
(foreign-lambda*
int ((int s) (scheme-pointer msg) (int offset) (int len) (int flags))
@@ -377,9 +380,12 @@ EOF
(read-input
(lambda ()
(let* ((tmr (tcp-read-timeout))
+ (d (fx- buflen bufindex))
(dlr (and tmr (+ (current-process-milliseconds) tmr))))
+ (when (fx> d 0)
+ (##core#inline "C_copy_memory_with_offset" buf buf 0 bufindex d))
(let loop ()
- (let ((n (recv fd buf +input-buffer-size+ 0)))
+ (let ((n (recv fd buf d (fx- +input-buffer-size+ d))))
(cond ((eq? _socket_error n)
(cond ((retry?)
(when dlr
@@ -397,21 +403,24 @@ EOF
(else
(network-error #f "cannot read from socket" fd) ) ) )
(else
- (set! buflen n)
- (##sys#setislot data 4 n)
- (set! bufindex 0) ) ) ) )) ) )
+ (let ((n2 (fx+ d n)))
+ (set! buflen n2)
+ (##sys#setislot data 4 n2)
+ (set! bufindex 0) ) ) ) )) ) ) )
(inport #f)
(in
(make-input-port
(lambda () ; read
- (when (fx>= bufindex buflen)
+ (when (fx>= (fx+ bufindex 4) buflen)
(read-input))
(if (fx>= bufindex buflen)
#!eof
- (##sys#decode-buffer buf bufindex 1 (##sys#slot inport 15)
- (lambda (buf start n)
- (set! bufindex (fx+ bufindex n))
- (##core#inline "C_utf_decode" buf start)))))
+ (##sys#read-char/encoding
+ inport (##sys#slot inport 15)
+ (lambda (buf start len dec)
+ (dec buf start len
+ (lambda (buf start len)
+ (##core#inline "C_utf_decode" buf start)))))))
(lambda () ; char-ready?
(or (fx< bufindex buflen)
;; XXX: This "knows" that check_fd_ready is
@@ -428,13 +437,18 @@ EOF
(network-error #f "cannot close socket input port" fd) ) ) )
peek-char:
(lambda () ; peek-char
- (when (fx>= bufindex buflen)
+ (when (fx>= (fx+ bufindex 4) buflen)
(read-input))
(if (fx>= bufindex buflen)
#!eof
- (##sys#decode-buffer buf bufindex 1 (##sys#slot inport 15)
- (lambda (buf start n)
- (##core#inline "C_utf_decode" buf start)))))
+ (let ((p bufindex))
+ (##sys#read-char/encoding
+ inport (##sys#slot inport 15)
+ (lambda (buf start len dec)
+ (dec buf start len
+ (lambda (buf start len)
+ (set! bufindex p)
+ (##core#inline "C_utf_decode" buf start))))))))
read-bytevector:
(lambda (dest start end) ; read-bytevector!
(let loop ((n (fx- end start)) (m 0) (start start))
@@ -447,7 +461,7 @@ EOF
(loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) )
(else
(read-input)
- (if (eq? buflen 0)
+ (if (fx>= bufindex buflen)
m
(loop n m start) ) ) ) ) )
read-line:
Trap