[Guile-commits] 05/07: Add put-u8 implementation in Scheme

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 7c8b80e076dd7d7219c985bcd8097dd1f115b92a
Author: Andy Wingo <address@hidden>
Date:   Tue May 24 08:24:38 2016 +0200

    Add put-u8 implementation in Scheme
    
    * module/ice-9/sports.scm (put-u8): Add implementation.
      (port-bindings): Add put-u8.
---
 module/ice-9/sports.scm |   17 ++++++++++++++++-
 1 file changed, 16 insertions(+), 1 deletion(-)

diff --git a/module/ice-9/sports.scm b/module/ice-9/sports.scm
index 52f887e..37ea092 100644
--- a/module/ice-9/sports.scm
+++ b/module/ice-9/sports.scm
@@ -62,6 +62,7 @@
             lookahead-u8
             get-u8
             get-bytevector-n
+            put-u8
             put-bytevector
 
             %read-line
@@ -307,6 +308,18 @@
        ((< (- count pos) (port-read-buffering port)) (buffer-and-fill pos))
        (else (fill-directly pos))))))
 
+(define (put-u8 port byte)
+  (when (port-random-access? port)
+    (flush-input port))
+  (let* ((buf (port-write-buffer port))
+         (bv (port-buffer-bytevector buf))
+         (end (port-buffer-end buf)))
+    (unless (<= 0 end (bytevector-length bv))
+      (error "not an output port" port))
+    (bytevector-u8-set! bv end byte)
+    (set-port-buffer-end! buf (1+ end))
+    (when (= (1+ end) (bytevector-length bv)) (flush-output port))))
+
 (define* (put-bytevector port src #:optional (start 0)
                          (count (- (bytevector-length src) start)))
   (unless (<= 0 start (+ start count) (bytevector-length src))
@@ -643,7 +656,9 @@
 (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 put-bytevector)
+    ((ice-9 binary-ports)
+     get-u8 lookahead-u8 get-bytevector-n
+     put-u8 put-bytevector)
     ((ice-9 rdelim) %read-line read-line read-delimited)))
 (define (install-sports!)
   (unless saved-port-bindings