[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 04/07: `put-bytevector' in Scheme
From: |
Andy Wingo |
Subject: |
[Guile-commits] 04/07: `put-bytevector' in Scheme |
Date: |
Tue, 24 May 2016 20:44:59 +0000 (UTC) |
wingo pushed a commit to branch master
in repository guile.
commit ba917410634e193e83ae408c5e0fffc04362544b
Author: Andy Wingo <address@hidden>
Date: Tue May 24 08:05:01 2016 +0200
`put-bytevector' in Scheme
* module/ice-9/sports.scm (flush-input): New helper.
(put-bytevector): New function.
(port-bindings): Add put-bytevector.
---
module/ice-9/sports.scm | 56 +++++++++++++++++++++++++++++++++++++++++++----
1 file changed, 52 insertions(+), 4 deletions(-)
diff --git a/module/ice-9/sports.scm b/module/ice-9/sports.scm
index cfa824c..52f887e 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
- [Guile-commits] branch master updated (6bf7ec0 -> 47918f3), Andy Wingo, 2016/05/24
- [Guile-commits] 02/07: close-port implementation in sports, Andy Wingo, 2016/05/24
- [Guile-commits] 06/07: Speed golf on Scheme put-u8, put-bytevector, Andy Wingo, 2016/05/24
- [Guile-commits] 07/07: Speed up scm_c_write / scm_lfwrite, Andy Wingo, 2016/05/24
- [Guile-commits] 01/07: Add force-output to sports, Andy Wingo, 2016/05/24
- [Guile-commits] 04/07: `put-bytevector' in Scheme,
Andy Wingo <=
- [Guile-commits] 03/07: Wire up non-blocking support in sport writes, Andy Wingo, 2016/05/24
- [Guile-commits] 05/07: Add put-u8 implementation in Scheme, Andy Wingo, 2016/05/24