[PATCH] Make get-bytevector-all suspendable.

[Christopher Baines <mail@cbaines.net>]

I'm looking at this since it's used in (web response)
read-response-body.

* module/ice-9/suspendable-ports.scm (get-bytevector-all): New
procedure.
(port-bindings): Add it.
---
 module/ice-9/suspendable-ports.scm | 36 ++++++++++++++++++++++++++++++
 1 file changed, 36 insertions(+)

diff --git a/module/ice-9/suspendable-ports.scm b/module/ice-9/suspendable-ports.scm
index 9fac1df62..e5b3de982 100644
--- a/module/ice-9/suspendable-ports.scm
+++ b/module/ice-9/suspendable-ports.scm
@@ -50,6 +50,7 @@
 
 (define-module (ice-9 suspendable-ports)
   #:use-module (rnrs bytevectors)
+  #:use-module (rnrs bytevectors gnu)
   #:use-module (ice-9 ports internal)
   #:use-module (ice-9 match)
   #:export (current-read-waiter
@@ -342,6 +343,40 @@
                 (set-port-buffer-cur! buf (+ cur transfer-size))
                 transfer-size))))))
 
+(define (get-bytevector-all port)
+  (define %initial-length 4096)
+
+  (let read-loop ((total 0)
+                  (result-length %initial-length)
+                  (result (make-bytevector %initial-length)))
+    (call-with-values (lambda () (fill-input port 1 'binary))
+      (lambda (buf cur buffered)
+        (if (zero? buffered)
+            (begin
+              (set-port-buffer-has-eof?! buf #f)
+              (if (= total 0)
+                  the-eof-object
+                  (bytevector-slice result 0 total)))
+            (let* ((new-total (+ total buffered))
+                   (new-result-length
+                    (let loop ((new-result-length result-length))
+                      (if (< new-total new-result-length)
+                          new-result-length
+                          (loop (* 2 new-result-length)))))
+                   (new-result
+                    (if (= new-result-length result-length)
+                        result
+                        (let ((new-result (make-bytevector new-result-length)))
+                          (bytevector-copy! result 0 new-result 0 total)
+                          new-result))))
+              (bytevector-copy! (port-buffer-bytevector buf) cur
+                                new-result total
+                                buffered)
+              (set-port-buffer-cur! buf (+ cur buffered))
+              (read-loop new-total
+                         new-result-length
+                         new-result)))))))
+
 (define (put-u8 port byte)
   (let* ((buf (port-write-buffer port))
          (bv (port-buffer-bytevector buf))
@@ -754,6 +789,7 @@
     ((ice-9 binary-ports)
      get-u8 lookahead-u8 get-bytevector-n get-bytevector-n!
      get-bytevector-some get-bytevector-some!
+     get-bytevector-all
      put-u8 put-bytevector)
     ((ice-9 textual-ports)
      put-char put-string)
-- 
2.41.0