~ chicken-core (chicken-5) 29a3bc5226fea8c41abd3703f7c0b88637b905c9
commit 29a3bc5226fea8c41abd3703f7c0b88637b905c9
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Jan 19 09:43:45 2011 -0500
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Jan 19 09:43:45 2011 -0500
added read-buffered, but currently undocumented
diff --git a/extras.scm b/extras.scm
index cbf6a6eb..a7bc4290 100644
--- a/extras.scm
+++ b/extras.scm
@@ -107,7 +107,8 @@
(##sys#substring buffer 0 i) ) ) ]
[else
(when (fx>= i buffer-len)
- (set! buffer (##sys#string-append buffer (make-string buffer-len)))
+ (set! buffer
+ (##sys#string-append buffer (make-string buffer-len)))
(set! buffer-len (fx+ buffer-len buffer-len)) )
(##core#inline "C_setsubchar" buffer i c)
(loop (fx+ i 1)) ] ) ) ) ) ) ) ) ) ) ) ) )
@@ -132,6 +133,16 @@
(##sys#check-port port 'read-lines)
(doread port) ) ) ) ) )
+(define write-line
+ (lambda (str . port)
+ (let ((p (if (##core#inline "C_eqp" port '())
+ ##sys#standard-output
+ (##sys#slot port 0) ) ) )
+ (##sys#check-port p 'write-line)
+ (##sys#check-string str 'write-line)
+ (display str p)
+ (newline p) ) ) )
+
;;; Extended I/O
@@ -199,6 +210,23 @@
(define (read-string #!optional n (port ##sys#standard-input))
(##sys#read-string/port n port) )
+;; <procedure>(read-buffered [PORT])</procedure>
+;;
+;; Reads any remaining data buffered after previous read operations on
+;; {{PORT}}. If no remaining data is currently buffered, an empty string
+;; is returned. This procedure will never block. Currently only useful for
+;; string-, process- and tcp ports.
+
+(define (read-buffered #!optional (port ##sys#standard-input))
+ (##sys#check-port port 'read-buffered)
+ (let ((rb (##sys#slot (##sys#slot port 2) 9))) ; read-buffered method
+ (if rb
+ (rb port)
+ "")))
+
+
+;;; read token of characters that satisfy a predicate
+
(define read-token
(lambda (pred . port)
(let ([port (optional port ##sys#standard-input)])
@@ -224,16 +252,6 @@
s)
port) ) ) )
-(define write-line
- (lambda (str . port)
- (let ((p (if (##core#inline "C_eqp" port '())
- ##sys#standard-output
- (##sys#slot port 0) ) ) )
- (##sys#check-port p 'write-line)
- (##sys#check-string str 'write-line)
- (display str p)
- (newline p) ) ) )
-
;;; Binary I/O
diff --git a/library.scm b/library.scm
index 8640c606..4635af06 100644
--- a/library.scm
+++ b/library.scm
@@ -1696,6 +1696,7 @@ EOF
; 6: (char-ready? PORT) -> BOOL
; 7: (read-string! PORT COUNT STRING START) -> COUNT'
; 8: (read-line PORT LIMIT) -> STRING | EOF
+; 9: (read-buffered PORT) -> STRING
(define (##sys#make-port i/o class name type)
(let ([port (##core#inline_allocate ("C_a_i_port" 17))])
@@ -1762,8 +1763,9 @@ EOF
(##sys#string-append result (##sys#substring buffer 0 n))]
[else
(##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
- (##sys#substring buffer 0 n)] ) ) ) ) )
- ) )
+ (##sys#substring buffer 0 n)] ) ) ) ) )
+ #f ; read-buffered
+ ) )
(define ##sys#open-file-port (##core#primitive "C_open_file_port"))
@@ -3391,7 +3393,17 @@ EOF
(let ((dest (##sys#make-string (fx- pos2 pos))))
(##core#inline "C_substring_copy" buf dest pos pos2 0)
(##sys#setislot p 10 next)
- dest) ) ) ) ) ) ) ) )
+ dest) ) ) ) ) )
+ (lambda (p) ; read-buffered
+ (let ((pos (##sys#slot p 10))
+ (string (##sys#slot p 12))
+ (len (##sys#slot p 11)) )
+ (if (fx>= pos len)
+ ""
+ (let ((buffered (##sys#substring string pos len)))
+ (##sys#setislot p 10 len)
+ buffered))))
+ )))
; Invokes the eol handler when EOL or EOS is reached.
(define (##sys#scan-buffer-line buf limit pos k)
diff --git a/ports.scm b/ports.scm
index 8f9e55a2..eee54b6d 100644
--- a/ports.scm
+++ b/ports.scm
@@ -32,9 +32,7 @@
; OF THE POSSIBILITY OF SUCH DAMAGE.
-(declare
- (unit ports)
- (hide read-and-write write-buf read-buf read-and-write-buf))
+(declare (unit ports))
(include "common-declarations.scm")
@@ -68,43 +66,39 @@
(define-constant +buf-size+ 1024)
-(define (read-buf port writer)
- (let ((buf (make-string +buf-size+)))
- (let loop ()
- (let ((n (read-string! +buf-size+ buf port)))
- (unless (eq? n 0)
- (writer buf n)
- (loop))))))
-
-(define (write-buf buf n port writer)
- (do ((i 0 (fx+ i 1)))
- ((fx>= i n))
- (writer (integer->char (##sys#byte buf i)) port)))
-
-(define (read-and-write reader writer)
- (let loop ()
- (let ((x (reader)))
- (unless (eof-object? x)
- (writer x)
- (loop)))))
-
-(define (read-and-write-buf src dest reader)
- (let ((buf (make-string +buf-size+)))
- (let loop ((n 0))
- (when (fx>= n +buf-size+)
- (write-string buf +buf-size+ dest)
- (set! n 0))
- (let ((c (reader src)))
- (cond ((eof-object? c)
- (when (fx>= n 0)
- (write-string buf n dest)))
- (else
- (##sys#setbyte buf n (char->integer c))
- (loop (fx+ n 1))))))))
-
(define copy-port
- (let ((read-char read-char) ; shadow here
+ (let ((read-char read-char)
(write-char write-char))
+ (define (read-buf port writer)
+ (let ((buf (make-string +buf-size+)))
+ (let loop ()
+ (let ((n (read-string! +buf-size+ buf port)))
+ (unless (eq? n 0)
+ (writer buf n)
+ (loop))))))
+ (define (write-buf buf n port writer)
+ (do ((i 0 (fx+ i 1)))
+ ((fx>= i n))
+ (writer (integer->char (##sys#byte buf i)) port)))
+ (define (read-and-write reader writer)
+ (let loop ()
+ (let ((x (reader)))
+ (unless (eof-object? x)
+ (writer x)
+ (loop)))))
+ (define (read-and-write-buf src dest reader)
+ (let ((buf (make-string +buf-size+)))
+ (let loop ((n 0))
+ (when (fx>= n +buf-size+)
+ (write-string buf +buf-size+ dest)
+ (set! n 0))
+ (let ((c (reader src)))
+ (cond ((eof-object? c)
+ (when (fx>= n 0)
+ (write-string buf n dest)))
+ (else
+ (##sys#setbyte buf n (char->integer c))
+ (loop (fx+ n 1))))))))
(lambda (src dest #!optional (read read-char) (write write-char))
;; does not check port args intentionally
(cond ((eq? read read-char)
@@ -131,6 +125,7 @@
(define (make-concatenated-port p1 . ports)
(let ((ports (cons p1 ports)))
+ ;;XXX should also forward other port-methods
(make-input-port
(lambda ()
(let loop ()
@@ -214,7 +209,7 @@
; 10: last
(define make-input-port
- (lambda (read ready? close #!optional peek read-string read-line)
+ (lambda (read ready? close #!optional peek read-string read-line read-buffered)
(let* ((class
(vector
(lambda (p) ; read-char
@@ -241,7 +236,8 @@
(lambda (p) ; char-ready?
(ready?) )
read-string ; read-string!
- read-line) ) ; read-line
+ read-line ; read-line
+ read-buffered))
(data (vector #f))
(port (##sys#make-port #t class "(custom)" 'custom)) )
(##sys#set-port-data! port data)
diff --git a/posixunix.scm b/posixunix.scm
index 65a2b1ac..5974b324 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -1351,8 +1351,7 @@ EOF
[buf (if (fixnum? bufi) (##sys#make-string bufi) bufi)]
[buflen 0]
[bufpos 0] )
- (let (
- [ready?
+ (let ([ready?
(lambda ()
(let ((res (##sys#file-select-one fd)))
(if (fx= -1 res)
@@ -1394,8 +1393,7 @@ EOF
[else
(set! buflen cnt)
(set! bufpos 0)]) ) ) ) )] )
- (letrec (
- [this-port
+ (letrec ([this-port
(make-input-port
(lambda () ; read-char
(fetch)
@@ -1464,7 +1462,14 @@ EOF
(fetch)
(if (fx< bufpos buflen)
(loop str)
- #!eof) ] ) ) ) ) ) ] )
+ #!eof) ] ) ) ) )
+ (lambda (port) ; read-buffered
+ (if (fx>= bufpos buflen)
+ ""
+ (let ((str (##sys#substring buf bufpos buflen)))
+ (set! bufpos buflen)
+ str)))
+ ) ] )
(set-port-name! this-port nam)
this-port ) ) ) ) )
diff --git a/tcp.scm b/tcp.scm
index bb397056..8fa181ed 100644
--- a/tcp.scm
+++ b/tcp.scm
@@ -447,7 +447,14 @@ EOF
(read-input)
(if (fx< bufindex buflen)
(loop str limit)
- #!eof) ) ) ) ) ) )
+ #!eof) ) ) ) )
+ (lambda (p) ; read-buffered
+ (if (fx>= bufindex buflen)
+ ""
+ (let ((str (##sys#substring buf bufpos buflen)))
+ (set! bufpos buflen)
+ str)))
+ ) )
(output
(lambda (s)
(let loop ((len (##sys#size s))
Trap