[Guile-commits] 02/02: Flush when getting string from r6rs string output port

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit e13cd5c77c030f22e3f5c27f15bb979bfda7d2ba
Author: Andy Wingo <address@hidden>
Date:   Wed Mar 1 14:24:41 2017 +0100

    Flush when getting string from r6rs string output port
    
    * module/rnrs/io/ports.scm (open-string-output-port): Calling the
      get-string proc should flush the buffer and reset the file position.
    * test-suite/tests/r6rs-ports.test ("8.2.10 Output ports"): Add tests.
      Thanks to Freja Nordsiek for the report.
---
 module/rnrs/io/ports.scm         |  6 +++++-
 test-suite/tests/r6rs-ports.test | 15 +++++++++++++++
 2 files changed, 20 insertions(+), 1 deletion(-)

diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
index e924ad8..5946067 100644
--- a/module/rnrs/io/ports.scm
+++ b/module/rnrs/io/ports.scm
@@ -387,7 +387,11 @@ read from/written to in @var{port}."
 as a string, and a thunk to retrieve the characters associated with that port."
   (let ((port (open-output-string)))
     (values port
-            (lambda () (get-output-string port)))))
+            (lambda ()
+              (let ((s (get-output-string port)))
+                (seek port 0 SEEK_SET)
+                (truncate-file port 0)
+                s)))))
 
 (define* (open-file-output-port filename
                                 #:optional
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index 94d9fc0..ba3131f 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -745,6 +745,21 @@ not `set-port-position!'"
   (with-test-prefix "open-file-output-port"
     (test-output-file-opener open-file-output-port (test-file)))
   
+  (pass-if "open-string-output-port"
+    (call-with-values open-string-output-port
+      (lambda (port proc)
+        (and (port? port) (thunk? proc)))))
+
+  (pass-if-equal "calling string output port truncates port"
+      '("hello" "" "world")
+    (call-with-values open-string-output-port
+      (lambda (port proc)
+        (display "hello" port)
+        (let* ((s1 (proc))
+               (s2 (proc)))
+          (display "world" port)
+          (list s1 s2 (proc))))))
+
   (pass-if "open-bytevector-output-port"
     (let-values (((port get-content)
                   (open-bytevector-output-port #f)))