[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/03: Implement R6RS output-port-buffer-mode
From: |
Andy Wingo |
Subject: |
[Guile-commits] 01/03: Implement R6RS output-port-buffer-mode |
Date: |
Tue, 21 Jun 2016 09:31:29 +0000 (UTC) |
wingo pushed a commit to branch master
in repository guile.
commit 5d9516637b68ddce3c5246a9a883e73cdcbc9097
Author: Andy Wingo <address@hidden>
Date: Tue Jun 21 11:06:25 2016 +0200
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 a132c53..e4a06fa 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 2968dbd..0cceb06 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 4941dd7..8c4ef57 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"