[Guile-commits] 04/07: `put-bytevector' in Scheme

[Andy Wingo]

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