From 9454068a54a4e9e84db61dc42d9a5d7a544a7ece Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Wed, 1 Jun 2016 12:01:16 +0200
Subject: [PATCH] put-string in Scheme

* module/ice-9/ports.scm: Export port-encode-chars and
  port-clear-stream-start-for-bom-write via the internals module.
* module/ice-9/sports.scm (put-string): New function.
---
 module/ice-9/ports.scm  |  4 ++++
 module/ice-9/sports.scm | 22 ++++++++++++++++++++++
 2 files changed, 26 insertions(+)

diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm
index 3fc2f6465..68afed1d4 100644
--- a/module/ice-9/ports.scm
+++ b/module/ice-9/ports.scm
@@ -182,10 +182,12 @@ interpret its input and output."
             port-read
             port-write
             port-clear-stream-start-for-bom-read
+            port-clear-stream-start-for-bom-write
             %port-encoding
             specialize-port-encoding!
             port-random-access?
             port-decode-char
+            port-encode-chars
             port-read-buffering
             port-poll
             port-read-wait-fd
@@ -227,9 +229,11 @@ interpret its input and output."
                        port-read
                        port-write
                        port-clear-stream-start-for-bom-read
+                       port-clear-stream-start-for-bom-write
                        %port-encoding
                        specialize-port-encoding!
                        port-decode-char
+                       port-encode-chars
                        port-random-access?
                        port-read-buffering
                        port-poll
diff --git a/module/ice-9/sports.scm b/module/ice-9/sports.scm
index 86d9a5b06..d145d071a 100644
--- a/module/ice-9/sports.scm
+++ b/module/ice-9/sports.scm
@@ -64,6 +64,7 @@
             get-bytevector-n
             put-u8
             put-bytevector
+            put-string
 
             %read-line
             read-line
@@ -653,6 +654,27 @@
 (define* (%read-line port)
   (read-line port 'split))
 
+(define* (put-string port str #:optional (start 0)
+                     (count (- (string-length str) start)))
+  (let* ((aux (port-auxiliary-write-buffer port))
+         (pos (port-buffer-position aux))
+         (line (port-position-line pos)))
+    (set-port-buffer-cur! aux 0)
+    (port-clear-stream-start-for-bom-write port aux)
+    (let lp ((encoded 0))
+      (when (< encoded count)
+        (let ((encoded (+ encoded
+                          (port-encode-chars port aux str
+                                             (+ start encoded)
+                                             (- count encoded)))))
+          (let ((end (port-buffer-end aux)))
+            (set-port-buffer-end! aux 0)
+            (put-bytevector port (port-buffer-bytevector aux) 0 end)
+            (lp encoded)))))
+    (when (and (not (eqv? line (port-position-line pos)))
+               (port-line-buffered? port))
+      (flush-output port))))
+
 (define saved-port-bindings #f)
 (define port-bindings
   '(((guile) read-char peek-char force-output close-port)