summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2016-05-24 08:05:01 +0200
committerAndy Wingo <wingo@pobox.com>2016-05-24 08:06:04 +0200
commitba917410634e193e83ae408c5e0fffc04362544b (patch)
tree2c6841d934f7dfefbd6446c2ec5d521d40e1f521
parent9686b04a265974f605848af64cf1348b6e452ad2 (diff)
downloadguile-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.scm56
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