From: Andreas Rottmann <a.rottmann@gmx.at>
To: Guile Development <guile-devel@gnu.org>
Subject: [PATCH 4/4] Work towards a more complete implementation of `(rnrs io ports)'
Date: Sat, 20 Nov 2010 18:40:33 +0100 [thread overview]
Message-ID: <1290274833-24970-4-git-send-email-a.rottmann@gmx.at> (raw)
In-Reply-To: <87ipzsvp9y.fsf@gnu.org>
* module/rnrs/io/ports.scm: Change into an R6RS library from a "regular"
Guile module, so the bookkeeping for #:re-export and #:replace is done
automatically and we gain control over the imports from `(guile)'.
(file-option, 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.
---
module/rnrs.scm | 18 +++-
module/rnrs/io/ports.scm | 283 +++++++++++++++++++++++++++++++++++++++------
module/rnrs/io/simple.scm | 23 +++--
3 files changed, 279 insertions(+), 45 deletions(-)
diff --git a/module/rnrs.scm b/module/rnrs.scm
index 14218f0..2a6e3df 100644
--- a/module/rnrs.scm
+++ b/module/rnrs.scm
@@ -162,13 +162,27 @@
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
+ 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
+ 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 ae8d0ea..dd6852a 100644
--- a/module/rnrs/io/ports.scm
+++ b/module/rnrs/io/ports.scm
@@ -26,34 +26,82 @@
;;;
;;; Code:
-(define-module (rnrs io ports)
- #:version (6)
- #:re-export (eof-object? port? input-port? output-port?)
- #:export (eof-object
-
- ;; input & output ports
- port-transcoder binary-port? transcoded-port
- port-position set-port-position!
- port-has-port-position? port-has-set-port-position!?
- call-with-port
-
- ;; input ports
- open-bytevector-input-port
- open-string-input-port
- make-custom-binary-input-port
-
- ;; binary input
- get-u8 lookahead-u8
- get-bytevector-n get-bytevector-n!
- get-bytevector-some get-bytevector-all
-
- ;; output ports
- open-bytevector-output-port
- open-string-output-port
- make-custom-binary-output-port
-
- ;; binary output
- put-u8 put-bytevector))
+(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 close-port
+
+ ;; input ports
+ open-bytevector-input-port
+ open-string-input-port
+ open-file-input-port
+ make-custom-binary-input-port
+
+ ;; binary input
+ get-u8 lookahead-u8
+ get-bytevector-n get-bytevector-n!
+ get-bytevector-some get-bytevector-all
+
+ ;; 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
+
+ ;; 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,73 @@
\f
;;;
+;;; 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)
+ (and (memq symbol '(none line block))))
+
+(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")
+
+(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)))))))
+
+\f
+;;;
;;; Input and output ports.
;;;
@@ -97,19 +212,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."
@@ -118,4 +247,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))
+
+
+\f
+(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 17acdf1..59e614d 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))
)
--
1.7.2.3
prev parent reply other threads:[~2010-11-20 17:40 UTC|newest]
Thread overview: 19+ messages / expand[flat|nested] mbox.gz Atom feed top
2010-11-15 21:45 Some work on the R6RS I/O libraries Andreas Rottmann
2010-11-19 23:59 ` Ludovic Courtès
2010-11-20 17:40 ` [PATCH 1/4] Fix missing port-table locking and bytevector output port segfault Andreas Rottmann
2010-11-20 22:43 ` Ludovic Courtès
2010-11-20 17:40 ` [PATCH 2/4] Add implementation of "transcoded ports" Andreas Rottmann
2010-11-20 22:52 ` Ludovic Courtès
2010-11-21 22:07 ` Andreas Rottmann
2010-11-21 22:17 ` [PATCH 1/4] Turn `(rnrs io ports)' into an R6RS library Andreas Rottmann
2010-11-21 22:17 ` [PATCH 2/4] Reorganize the R6RS I/O condition types Andreas Rottmann
2010-11-21 22:17 ` [PATCH 3/4] Work towards a more complete implementation of `(rnrs io ports)' Andreas Rottmann
2010-11-23 21:13 ` Ludovic Courtès
2010-11-23 23:44 ` Andreas Rottmann
2010-11-24 20:24 ` Ludovic Courtès
2010-11-21 22:17 ` [PATCH 4/4] Add implementation of "transcoded ports" Andreas Rottmann
2010-11-24 22:29 ` Ludovic Courtès
2010-11-25 0:08 ` Andreas Rottmann
2010-11-25 21:15 ` Ludovic Courtès
2010-11-20 17:40 ` [PATCH 3/4] Reorganize the R6RS I/O condition types Andreas Rottmann
2010-11-20 17:40 ` Andreas Rottmann [this message]
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=1290274833-24970-4-git-send-email-a.rottmann@gmx.at \
--to=a.rottmann@gmx.at \
--cc=guile-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).