[Guile-commits] 02/02: get-bytevector-n in Scheme.

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit c95a19376b1f2fd26c60fb56c1c9892eef1acfc4
Author: Andy Wingo <address@hidden>
Date:   Sun May 22 23:02:41 2016 +0200

    get-bytevector-n in Scheme.
    
    * module/ice-9/sports.scm (fill-input): Add io-mode optional arg.
      (get-bytevector-n): New implementation.
      (port-bindings): Add get-bytevector-n.
    * test-suite/tests/sports.test: Add r6rs-ports tests.
---
 module/ice-9/sports.scm      |   53 +++++++++++++++++++++++++++++++++++++++---
 test-suite/tests/sports.test |    1 +
 2 files changed, 51 insertions(+), 3 deletions(-)

diff --git a/module/ice-9/sports.scm b/module/ice-9/sports.scm
index ce782d8..807eada 100644
--- a/module/ice-9/sports.scm
+++ b/module/ice-9/sports.scm
@@ -56,6 +56,7 @@
              read-char)
   #:export (lookahead-u8
             get-u8
+            get-bytevector-n
             %read-line
             read-line
             read-delimited
@@ -148,8 +149,8 @@
          (maybe-consume-bom utf32be-bom)
          (specialize-port-encoding! port 'UTF-32BE)))))))
 
-(define* (fill-input port #:optional (minimum-buffering 1))
-  (clear-stream-start-for-bom-read port 'text)
+(define* (fill-input port #:optional (minimum-buffering 1) (io-mode 'text))
+  (clear-stream-start-for-bom-read port io-mode)
   (let* ((buf (port-read-buffer port))
          (cur (port-buffer-cur buf))
          (buffered (- (port-buffer-end buf) cur)))
@@ -226,6 +227,52 @@
         (fast-path buf bv cur buffered)))
   (peek-bytes port 1 fast-path slow-path))
 
+(define* (get-bytevector-n port count)
+  (let ((ret (make-bytevector count)))
+    (define (port-buffer-take! pos buf cur to-copy)
+      (bytevector-copy! (port-buffer-bytevector buf) cur
+                        ret pos to-copy)
+      (set-port-buffer-cur! buf (+ cur to-copy))
+      (+ pos to-copy))
+    (define (take-already-buffered)
+      (let* ((buf (port-read-buffer port))
+             (cur (port-buffer-cur buf))
+             (buffered (- (port-buffer-end buf) cur)))
+        (port-buffer-take! 0 buf cur (min count buffered))))
+    (define (trim-and-return len)
+      (if (zero? len)
+          the-eof-object
+          (let ((partial (make-bytevector len)))
+            (bytevector-copy! ret 0 partial 0 len)
+            partial)))
+    (define (buffer-and-fill pos)
+      (call-with-values (lambda () (fill-input port 1 'binary))
+        (lambda (buf buffered)
+          (if (zero? buffered)
+              (begin
+                (set-port-buffer-has-eof?! buf #f)
+                (trim-and-return pos))
+              (let ((pos (port-buffer-take! pos buf (port-buffer-cur buf)
+                                            (min (- count pos) buffered))))
+                (if (= pos count)
+                    ret
+                    (buffer-and-fill pos)))))))
+    (define (fill-directly pos)
+      (when (port-random-access? port)
+        (flush-output port))
+      (port-clear-stream-start-for-bom-read port)
+      (let lp ((pos pos))
+        (let ((read (read-bytes port ret pos (- count pos))))
+          (cond
+           ((= read (- count pos)) ret)
+           ((zero? read) (trim-and-return pos))
+           (else (lp (+ pos read)))))))
+    (let ((pos (take-already-buffered)))
+      (cond
+       ((= pos count) (if (zero? pos) the-eof-object ret))
+       ((< (- count pos) (port-read-buffering port)) (buffer-and-fill pos))
+       (else (fill-directly pos))))))
+
 (define (decoding-error subr port)
   ;; GNU definition; fixme?
   (define EILSEQ 84)
@@ -527,7 +574,7 @@
 (define saved-port-bindings #f)
 (define port-bindings
   '(((guile) read-char peek-char)
-    ((ice-9 binary-ports) get-u8 lookahead-u8)
+    ((ice-9 binary-ports) get-u8 lookahead-u8 get-bytevector-n)
     ((ice-9 rdelim) %read-line read-line read-delimited)))
 (define (install-sports!)
   (unless saved-port-bindings
diff --git a/test-suite/tests/sports.test b/test-suite/tests/sports.test
index 6707f56..453e35f 100644
--- a/test-suite/tests/sports.test
+++ b/test-suite/tests/sports.test
@@ -53,5 +53,6 @@
 
 (include-tests "tests/ports.test")
 (include-tests "tests/rdelim.test")
+(include-tests "tests/r6rs-ports.test")
 
 (uninstall-sports!)