~ chicken-core (chicken-5) 7fdc4b41b4a7b2a78afd33f73bc5d2ea07e6d60c
commit 7fdc4b41b4a7b2a78afd33f73bc5d2ea07e6d60c
Author: Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Wed Feb 20 22:19:07 2013 +0100
Commit: Christian Kellermann <ckeen@pestilenz.org>
CommitDate: Sat Mar 16 19:52:51 2013 +0100
Fix #985 by making process ports consistent with TCP ports.
This causes it to call "fetch" only when more data is requested
than available in the buffer, instead of always calling "fetch" and
checking inside the procedure whether we need more data.
The bug was due to the fact that fetch checked the position was at
the end of the buffer, but it wasn't since ##sys#scan-buffer-line
and the posix eos-handler doesn't advance the position while reading
(only afterwards, assuming "fetch" would reset the position).
Signed-off-by: Christian Kellermann <ckeen@pestilenz.org>
diff --git a/posixunix.scm b/posixunix.scm
index 650d2c33..6d1fe512 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -1318,40 +1318,38 @@ EOF
(##core#inline "C_subchar" buf bufpos)) )]
[fetch
(lambda ()
- (when (fx>= bufpos buflen)
- (let loop ()
- (let ([cnt (##core#inline "C_read" fd buf bufsiz)])
- (cond ((fx= cnt -1)
- (select _errno
- ((_ewouldblock _eagain)
- (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
- (##sys#thread-yield!)
- (loop) )
- ((_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 (or (fx= _errno _ewouldblock)
- (fx= _errno _eagain))
- (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)]) ) ) ) )] )
+ (let loop ()
+ (let ([cnt (##core#inline "C_read" fd buf bufsiz)])
+ (cond ((fx= cnt -1)
+ (select _errno
+ ((_ewouldblock _eagain)
+ (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
+ (##sys#thread-yield!)
+ (loop) )
+ ((_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 (or (fx= _errno _ewouldblock)
+ (fx= _errno _eagain))
+ (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)]) ) ) )] )
(letrec ([this-port
(make-input-port
(lambda () ; read-char
- (fetch)
(let ([ch (peek)])
#; ; Allow increment since overflow is far, far away
(unless (eof-object? ch) (set! bufpos (fx+ bufpos 1)))
@@ -1367,22 +1365,23 @@ EOF
(posix-error #:file-error loc "cannot close" fd nam) )
(on-close) ) )
(lambda () ; peek-char
- (fetch)
+ (when (fx>= bufpos buflen)
+ (fetch))
(peek) )
(lambda (port n dest start) ; read-string!
(let loop ([n (or n (fx- (##sys#size dest) start))] [m 0] [start start])
(cond [(eq? 0 n) m]
[(fx< bufpos buflen)
- (let* ([rest (fx- buflen bufpos)]
- [n2 (if (fx< n rest) n rest)])
- (##core#inline "C_substring_copy" buf dest bufpos (fx+ bufpos n2) start)
- (set! bufpos (fx+ bufpos n2))
- (loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) ]
+ (let* ([rest (fx- buflen bufpos)]
+ [n2 (if (fx< n rest) n rest)])
+ (##core#inline "C_substring_copy" buf dest bufpos (fx+ bufpos n2) start)
+ (set! bufpos (fx+ bufpos n2))
+ (loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) ]
[else
- (fetch)
- (if (eq? 0 buflen)
- m
- (loop n m start) ) ] ) ) )
+ (fetch)
+ (if (eq? 0 buflen)
+ m
+ (loop n m start) ) ] ) ) )
(lambda (port limit) ; read-line
(when (fx>= bufpos buflen)
(fetch))
Trap