summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndreas Rottmann <a.rottmann@gmx.at>2010-11-21 23:17:53 +0100
committerLudovic Courtès <ludo@gnu.org>2010-11-24 23:04:24 +0100
commita5484153b83b04f8e9bbe392b97904e9493da44e (patch)
tree031660914aaf8a3c05797b1ae854060c4705cc52
parent50851f1d182f41ff4fc3a5f2c967231575da4d94 (diff)
downloadguile-a5484153b83b04f8e9bbe392b97904e9493da44e.tar.gz
Work towards a more complete implementation of `(rnrs io ports)'
* module/rnrs/io/ports.scm: (file-options, buffer-mode, eol-style) (error-handling-mode, make-transcoder, native-transcoder) (latin-1-codec, utf-8-codec, utf-16-codec) (call-with-bytevector-output-port, open-file-input-port) (open-file-output-port, make-custom-textual-output-port) (flush-output-port, put-char, put-datum, put-string, get-char) (get-datum, get-line, get-string-all, lookahead-char) (standard-input-port, standard-output-port, standard-error-port): Define all of these. (call-with-port): Don't use `dynamic-wind', as it is against its specification in R6RS 8.2.6. * module/rnrs.scm: Export procedures added. * module/rnrs/io/simple.scm (call-with-input-file) (call-with-output-file): Define these in terms of R6RS procedures to get correct exception behavior. Signed-off-by: Ludovic Courtès <ludo@gnu.org>
-rw-r--r--module/rnrs.scm20
-rw-r--r--module/rnrs/io/ports.scm238
-rw-r--r--module/rnrs/io/simple.scm23
3 files changed, 260 insertions, 21 deletions
diff --git a/module/rnrs.scm b/module/rnrs.scm
index 14218f0a3..e10967bb4 100644
--- a/module/rnrs.scm
+++ b/module/rnrs.scm
@@ -160,15 +160,31 @@
;; (rnrs io ports)
+ file-options buffer-mode buffer-mode?
+ eol-style native-eol-style error-handling-mode
+ make-transcoder transcoder-codec native-transcoder
+ latin-1-codec utf-8-codec utf-16-codec
+
eof-object? port? input-port? output-port? eof-object port-transcoder
binary-port? transcoded-port port-position set-port-position!
- port-has-port-position? port-has-set-port-position!? call-with-port
+ port-has-port-position? port-has-set-port-position!?
+ close-port call-with-port
open-bytevector-input-port make-custom-binary-input-port get-u8
lookahead-u8 get-bytevector-n get-bytevector-n! get-bytevector-some
get-bytevector-all open-bytevector-output-port
make-custom-binary-output-port put-u8 put-bytevector
open-string-input-port open-string-output-port
-
+ call-with-bytevector-output-port
+ call-with-string-output-port
+ latin-1-codec utf-8-codec utf-16-codec
+ open-file-input-port open-file-output-port
+ make-custom-textual-output-port
+ call-with-string-output-port
+ flush-output-port put-string
+ get-char get-datum get-line get-string-all lookahead-char
+ put-char put-datum put-string
+ standard-input-port standard-output-port standard-error-port
+
;; (rnrs io simple)
call-with-input-file call-with-output-file current-input-port
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
index 22460496f..31c1e2935 100644
--- a/module/rnrs/io/ports.scm
+++ b/module/rnrs/io/ports.scm
@@ -29,16 +29,23 @@
(library (rnrs io ports (6))
(export eof-object eof-object?
+ ;; auxiliary types
+ file-options buffer-mode buffer-mode?
+ eol-style native-eol-style error-handling-mode
+ make-transcoder transcoder-codec native-transcoder
+ latin-1-codec utf-8-codec utf-16-codec
+
;; input & output ports
port? input-port? output-port?
port-transcoder binary-port? transcoded-port
port-position set-port-position!
port-has-port-position? port-has-set-port-position!?
- call-with-port
+ call-with-port close-port
;; input ports
open-bytevector-input-port
open-string-input-port
+ open-file-input-port
make-custom-binary-input-port
;; binary input
@@ -49,11 +56,52 @@
;; output ports
open-bytevector-output-port
open-string-output-port
+ open-file-output-port
make-custom-binary-output-port
-
+ call-with-bytevector-output-port
+ call-with-string-output-port
+ make-custom-textual-output-port
+ flush-output-port
+
;; binary output
- put-u8 put-bytevector)
- (import (guile))
+ put-u8 put-bytevector
+
+ ;; textual input
+ get-char get-datum get-line get-string-all lookahead-char
+
+ ;; textual output
+ put-char put-datum put-string
+
+ ;; standard ports
+ standard-input-port standard-output-port standard-error-port
+
+ ;; condition types
+ &i/o i/o-error? make-i/o-error
+ &i/o-read i/o-read-error? make-i/o-read-error
+ &i/o-write i/o-write-error? make-i/o-write-error
+ &i/o-invalid-position i/o-invalid-position-error?
+ make-i/o-invalid-position-error
+ &i/o-filename i/o-filename-error? make-i/o-filename-error
+ i/o-error-filename
+ &i/o-file-protection i/o-file-protection-error?
+ make-i/o-file-protection-error
+ &i/o-file-is-read-only i/o-file-is-read-only-error?
+ make-i/o-file-is-read-only-error
+ &i/o-file-already-exists i/o-file-already-exists-error?
+ make-i/o-file-already-exists-error
+ &i/o-file-does-not-exist i/o-file-does-not-exist-error?
+ make-i/o-file-does-not-exist-error
+ &i/o-port i/o-port-error? make-i/o-port-error
+ i/o-error-port)
+ (import (only (rnrs base) assertion-violation)
+ (rnrs enums)
+ (rnrs records syntactic)
+ (rnrs exceptions)
+ (rnrs conditions)
+ (rnrs files) ;for the condition types
+ (srfi srfi-8)
+ (ice-9 rdelim)
+ (except (guile) raise))
(load-extension (string-append "libguile-" (effective-version))
"scm_init_r6rs_ports")
@@ -61,6 +109,78 @@
;;;
+;;; Auxiliary types
+;;;
+
+(define-enumeration file-option
+ (no-create no-fail no-truncate)
+ file-options)
+
+(define-enumeration buffer-mode
+ (none line block)
+ buffer-modes)
+
+(define (buffer-mode? symbol)
+ (enum-set-member? symbol (enum-set-universe (buffer-modes))))
+
+(define-enumeration eol-style
+ (lf cr crlf nel crnel ls)
+ eol-styles)
+
+(define (native-eol-style)
+ (eol-style lf))
+
+(define-enumeration error-handling-mode
+ (ignore raise replace)
+ error-handling-modes)
+
+(define-record-type (transcoder %make-transcoder transcoder?)
+ (fields codec eol-style error-handling-mode))
+
+(define* (make-transcoder codec
+ #:optional
+ (eol-style (native-eol-style))
+ (handling-mode (error-handling-mode replace)))
+ (%make-transcoder codec eol-style handling-mode))
+
+(define (native-transcoder)
+ (make-transcoder (or (fluid-ref %default-port-encoding)
+ (latin-1-codec))))
+
+(define (latin-1-codec)
+ "ISO-8859-1")
+
+(define (utf-8-codec)
+ "UTF-8")
+
+(define (utf-16-codec)
+ "UTF-16")
+
+
+;;;
+;;; Internal helpers
+;;;
+
+(define (with-i/o-filename-conditions filename thunk)
+ (catch 'system-error
+ thunk
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (let ((construct-condition
+ (cond ((= errno EACCES)
+ make-i/o-file-protection-error)
+ ((= errno EEXIST)
+ make-i/o-file-already-exists-error)
+ ((= errno ENOENT)
+ make-i/o-file-does-not-exist-error)
+ ((= errno EROFS)
+ make-i/o-file-is-read-only-error)
+ (else
+ make-i/o-filename-error))))
+ (raise (construct-condition filename)))))))
+
+
+;;;
;;; Input and output ports.
;;;
@@ -100,19 +220,33 @@ read from/written to in @var{port}."
(define (call-with-port port proc)
"Call @var{proc}, passing it @var{port} and closing @var{port} upon exit of
@var{proc}. Return the return values of @var{proc}."
- (dynamic-wind
- (lambda ()
- #t)
- (lambda ()
- (proc port))
- (lambda ()
- (close-port port))))
+ (call-with-values
+ (lambda () (proc port))
+ (lambda vals
+ (close-port port)
+ (apply values vals))))
+
+(define* (call-with-bytevector-output-port proc #:optional (transcoder #f))
+ (receive (port extract) (open-bytevector-output-port transcoder)
+ (call-with-port port proc)
+ (extract)))
(define (open-string-input-port str)
"Open an input port that will read from @var{str}."
(with-fluids ((%default-port-encoding "UTF-8"))
(open-input-string str)))
+(define* (open-file-input-port filename
+ #:optional
+ (file-options (file-options))
+ (buffer-mode (buffer-mode block))
+ maybe-transcoder)
+ (let ((port (with-i/o-filename-conditions filename
+ (lambda () (open filename O_RDONLY)))))
+ (cond (maybe-transcoder
+ (set-port-encoding! port (transcoder-codec maybe-transcoder))))
+ port))
+
(define (open-string-output-port)
"Return two values: an output port that will collect characters written to it
as a string, and a thunk to retrieve the characters associated with that port."
@@ -121,6 +255,88 @@ as a string, and a thunk to retrieve the characters associated with that port."
(values port
(lambda () (get-output-string port)))))
+(define* (open-file-output-port filename
+ #:optional
+ (file-options (file-options))
+ (buffer-mode (buffer-mode block))
+ maybe-transcoder)
+ (let* ((flags (logior O_WRONLY
+ (if (enum-set-member? 'no-create file-options)
+ 0
+ O_CREAT)
+ (if (enum-set-member? 'no-truncate file-options)
+ 0
+ O_TRUNC)))
+ (port (with-i/o-filename-conditions filename
+ (lambda () (open filename flags)))))
+ (cond (maybe-transcoder
+ (set-port-encoding! port (transcoder-codec maybe-transcoder))))
+ port))
+
+(define (call-with-string-output-port proc)
+ "Call @var{proc}, passing it a string output port. When @var{proc} returns,
+return the characters accumulated in that port."
+ (let ((port (open-output-string)))
+ (proc port)
+ (get-output-string port)))
+
+(define (make-custom-textual-output-port id
+ write!
+ get-position
+ set-position!
+ close)
+ (make-soft-port (vector (lambda (c) (write! (string c) 0 1))
+ (lambda (s) (write! s 0 (string-length s)))
+ #f ;flush
+ #f ;read character
+ close)
+ "w"))
+
+(define (flush-output-port port)
+ (force-output port))
+
+(define (put-char port char)
+ (write-char char port))
+
+(define (put-datum port datum)
+ (write datum port))
+
+(define* (put-string port s #:optional start count)
+ (cond ((not (string? s))
+ (assertion-violation 'put-string "expected string" s))
+ ((and start count)
+ (display (substring/shared s start (+ start count)) port))
+ (start
+ (display (substring/shared s start (string-length s)) port))
+ (else
+ (display s port))))
+
+(define (get-char port)
+ (read-char port))
+
+(define (get-datum port)
+ (read port))
+
+(define (get-line port)
+ (read-line port 'trim))
+
+(define (get-string-all port)
+ (read-delimited "" port 'concat))
+
+(define (lookahead-char port)
+ (peek-char port))
+
+
+
+(define (standard-input-port)
+ (dup->inport 0))
+
+(define (standard-output-port)
+ (dup->outport 1))
+
+(define (standard-error-port)
+ (dup->outport 2))
+
)
;;; ports.scm ends here
diff --git a/module/rnrs/io/simple.scm b/module/rnrs/io/simple.scm
index 17acdf1c4..59e614de0 100644
--- a/module/rnrs/io/simple.scm
+++ b/module/rnrs/io/simple.scm
@@ -83,15 +83,16 @@
i/o-port-error?
i/o-error-port)
- (import (only (rnrs io ports) eof-object
- eof-object?
-
- input-port?
- output-port?)
+ (import (only (rnrs io ports)
+ call-with-port
+ open-file-input-port
+ open-file-output-port
+ eof-object
+ eof-object?
+
+ input-port?
+ output-port?)
(only (guile) @@
- call-with-input-file
- call-with-output-file
-
current-input-port
current-output-port
current-error-port
@@ -115,5 +116,11 @@
(rnrs base (6))
(rnrs files (6)) ;for the condition types
)
+
+ (define (call-with-input-file filename proc)
+ (call-with-port (open-file-input-port filename) proc))
+
+ (define (call-with-output-file filename proc)
+ (call-with-port (open-file-output-port filename) proc))
)