From 5d9516637b68ddce3c5246a9a883e73cdcbc9097 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Tue, 21 Jun 2016 11:06:25 +0200
Subject: [PATCH] Implement R6RS output-port-buffer-mode

* module/rnrs/io/ports.scm (r6rs-open): Set buffer-mode on new port.
  (output-port-buffer-mode): Implement and export.
* module/rnrs.scm (rnrs): Export output-port-buffer-mode
* test-suite/tests/r6rs-ports.test (test-output-file-opener): Add
  tests.
---
 module/rnrs.scm                  |  2 +-
 module/rnrs/io/ports.scm         | 19 +++++++++++++++++--
 test-suite/tests/r6rs-ports.test | 18 ++++++++++++++++++
 3 files changed, 36 insertions(+), 3 deletions(-)

diff --git a/module/rnrs.scm b/module/rnrs.scm
index a132c5364..e4a06faf5 100644
--- a/module/rnrs.scm
+++ b/module/rnrs.scm
@@ -183,7 +183,7 @@
           open-file-input-port open-file-output-port open-file-input/output-port
           make-custom-textual-output-port
           call-with-string-output-port
-	  flush-output-port put-string
+	  output-port-buffer-mode flush-output-port put-string
           get-char get-datum get-line get-string-all get-string-n get-string-n!
           lookahead-char
           put-char put-datum put-string
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
index 2968dbd9f..0cceb0672 100644
--- a/module/rnrs/io/ports.scm
+++ b/module/rnrs/io/ports.scm
@@ -63,6 +63,7 @@
           call-with-bytevector-output-port
           call-with-string-output-port
           make-custom-textual-output-port
+          output-port-buffer-mode
           flush-output-port
 
           ;; input/output ports
@@ -106,6 +107,9 @@
           make-i/o-encoding-error i/o-encoding-error-char)
   (import (ice-9 binary-ports)
           (only (rnrs base) assertion-violation)
+          (only (ice-9 ports internal)
+                port-write-buffer port-buffer-bytevector port-line-buffered?)
+          (only (rnrs bytevectors) bytevector-length)
           (rnrs enums)
           (rnrs records syntactic)
           (rnrs exceptions)
@@ -310,8 +314,9 @@ read from/written to in @var{port}."
                 (lambda ()
                   (with-fluids ((%default-port-encoding #f))
                     (open filename mode))))))
-    (cond (transcoder
-           (set-port-encoding! port (transcoder-codec transcoder))))
+    (setvbuf port buffer-mode)
+    (when transcoder
+      (set-port-encoding! port (transcoder-codec transcoder)))
     port))
 
 (define (file-options->mode file-options base-mode)
@@ -382,6 +387,16 @@ return the characters accumulated in that port."
                           close)
                   "w"))
 
+(define (output-port-buffer-mode port)
+  "Return @code{none} if @var{port} is unbuffered, @code{line} if it is
+line buffered, or @code{block} otherwise."
+  (let ((buffering (bytevector-length
+                    (port-buffer-bytevector (port-write-buffer port)))))
+    (cond
+     ((= buffering 1) 'none)
+     ((port-line-buffered? port) 'line)
+     (else 'block))))
+
 (define (flush-output-port port)
   (force-output port))
 
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index 4941dd718..8c4ef57e1 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -716,6 +716,24 @@ not `set-port-position!'"
                binary-port?)
              (= 0 (stat:size (stat filename)))))
     
+  (pass-if "buffer-mode none"
+           (call-with-port (open filename (file-options no-fail)
+                                 (buffer-mode none))
+             (lambda (port)
+               (eq? (output-port-buffer-mode port) 'none))))
+
+  (pass-if "buffer-mode line"
+           (call-with-port (open filename (file-options no-fail)
+                                 (buffer-mode line))
+             (lambda (port)
+               (eq? (output-port-buffer-mode port) 'line))))
+
+  (pass-if "buffer-mode block"
+           (call-with-port (open filename (file-options no-fail)
+                                 (buffer-mode block))
+             (lambda (port)
+               (eq? (output-port-buffer-mode port) 'block))))
+
   (delete-file filename)
     
   (pass-if-condition "exception: does-not-exist"