diff options
author | Andy Wingo <wingo@pobox.com> | 2016-05-24 08:05:01 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2016-05-24 08:06:04 +0200 |
commit | ba917410634e193e83ae408c5e0fffc04362544b (patch) | |
tree | 2c6841d934f7dfefbd6446c2ec5d521d40e1f521 | |
parent | 9686b04a265974f605848af64cf1348b6e452ad2 (diff) | |
download | guile-ba917410634e193e83ae408c5e0fffc04362544b.tar.gz |
`put-bytevector' in Scheme
* module/ice-9/sports.scm (flush-input): New helper.
(put-bytevector): New function.
(port-bindings): Add put-bytevector.
-rw-r--r-- | module/ice-9/sports.scm | 56 |
1 files changed, 52 insertions, 4 deletions
diff --git a/module/ice-9/sports.scm b/module/ice-9/sports.scm index cfa824c83..52f887e24 100644 --- a/module/ice-9/sports.scm +++ b/module/ice-9/sports.scm @@ -56,14 +56,18 @@ read-char force-output close-port) - #:export (lookahead-u8 + #:export (current-read-waiter + current-write-waiter + + lookahead-u8 get-u8 get-bytevector-n + put-bytevector + %read-line read-line read-delimited - current-read-waiter - current-write-waiter + install-sports! uninstall-sports!)) @@ -99,6 +103,15 @@ (wait-for-writable port) (write-bytes port src start count)))) +(define (flush-input port) + (let* ((buf (port-read-buffer port)) + (cur (port-buffer-cur buf)) + (end (port-buffer-end buf))) + (when (< cur end) + (set-port-buffer-cur! buf 0) + (set-port-buffer-end! buf 0) + (seek port (- cur end) SEEK_CUR)))) + (define (flush-output port) (let* ((buf (port-write-buffer port)) (cur (port-buffer-cur buf)) @@ -294,6 +307,41 @@ ((< (- count pos) (port-read-buffering port)) (buffer-and-fill pos)) (else (fill-directly pos)))))) +(define* (put-bytevector port src #:optional (start 0) + (count (- (bytevector-length src) start))) + (unless (<= 0 start (+ start count) (bytevector-length src)) + (error "invalid start/count" start count)) + (when (port-random-access? port) + (flush-input port)) + (let* ((buf (port-write-buffer port)) + (bv (port-buffer-bytevector buf)) + (size (bytevector-length bv)) + (cur (port-buffer-cur buf)) + (end (port-buffer-end buf)) + (buffered (- end cur))) + (cond + ((<= size count) + ;; The write won't fit in the buffer at all; write directly. + ;; Write directly. Flush write buffer first if needed. + (when (< cur end) (flush-output port)) + (write-bytes port src start count)) + ((< (- size buffered) count) + ;; The write won't fit into the buffer along with what's already + ;; buffered. Flush and fill. + (flush-output port) + (set-port-buffer-end! buf count) + (bytevector-copy! src start bv 0 count)) + (else + ;; The write will fit in the buffer, but we need to shuffle the + ;; already-buffered bytes (if any) down. + (set-port-buffer-cur! buf 0) + (set-port-buffer-end! buf (+ buffered count)) + (bytevector-copy! bv cur bv 0 buffered) + (bytevector-copy! src start bv buffered count) + ;; If the buffer completely fills, we flush. + (when (= (+ buffered count) size) + (flush-output port)))))) + (define (decoding-error subr port) ;; GNU definition; fixme? (define EILSEQ 84) @@ -595,7 +643,7 @@ (define saved-port-bindings #f) (define port-bindings '(((guile) read-char peek-char force-output close-port) - ((ice-9 binary-ports) get-u8 lookahead-u8 get-bytevector-n) + ((ice-9 binary-ports) get-u8 lookahead-u8 get-bytevector-n put-bytevector) ((ice-9 rdelim) %read-line read-line read-delimited))) (define (install-sports!) (unless saved-port-bindings |