* Some work on the R6RS I/O libraries
@ 2010-11-15 21:45 Andreas Rottmann
2010-11-19 23:59 ` Ludovic Courtès
0 siblings, 1 reply; 19+ messages in thread
From: Andreas Rottmann @ 2010-11-15 21:45 UTC (permalink / raw)
To: Guile Development
[-- Attachment #1: Type: text/plain, Size: 2416 bytes --]
Fix missing port-table locking and bytevector output port segfault.
* libguile/r6rs-ports.c (make_bip, make_cbip, make_bop, make_cbop): Lock
the port table.
* libguile/r6rs-ports.c (make_bop): Let the returned extraction
procedure refer to the port's buffer instead of the port itself. This
fixes a segfault if the port is closed before the extraction procedure
is called.
(bop_proc_apply): Adapt accordingly.
* test-suite/tests/r6rs-ports.test (8.2.10 Output ports): Add testcase
for extraction after close.
Add implementation of "transcoded ports".
* libguile/r6rs-ports.c (make_tp, tp_write, tp_fill_input, tp_flush,
tp_close, initialize_transcoded_ports, scm_transcoded_port): New
functions.
(scm_init_r6rs_ports): Call `initialize_transcoded_ports'.
* module/rnrs/ports.scm (transcoded-port): Remove, this is now
implemented in C.
* test-suite/tests/r6rs-ports.test (8.2.6 Input and output ports): Added a
few tests for `transcoded-port'.
Move the I/O condition types from `(rnrs conditions)', where they were
not exported, to `(rnrs files)', where they are.
* module/rnrs/conditions.scm: Remove definition of I/O condition types.
* module/rnrs/files.scm: Replace references to I/O condition types
inside `(rnrs conditions)' with the actual definitions.
* module/rnrs/io/simple.scm: Don't `@@'-reference the I/O condition types, just
imported them from `(rnrs files)'.
Work towards a more complete implementation of `(rnrs io ports)'.
* 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/io/simple.scm (call-with-input-file,
call-with-output-file): Define these in terms of R6RS procedures to
get correct exception behavior.
[-- Attachment #2: rnrs-io-ports.diff --]
[-- Type: text/x-diff, Size: 37813 bytes --]
From: Andreas Rottmann <a.rottmann@gmx.at>
Subject: Some work on the R6RS I/O libraries
Fix missing port-table locking and bytevector output port segfault.
* libguile/r6rs-ports.c (make_bip, make_cbip, make_bop, make_cbop): Lock
the port table.
* libguile/r6rs-ports.c (make_bop): Let the returned extraction
procedure refer to the port's buffer instead of the port itself. This
fixes a segfault if the port is closed before the extraction procedure
is called.
(bop_proc_apply): Adapt accordingly.
* test-suite/tests/r6rs-ports.test (8.2.10 Output ports): Add testcase
for extraction after close.
Add implementation of "transcoded ports".
* libguile/r6rs-ports.c (make_tp, tp_write, tp_fill_input, tp_flush,
tp_close, initialize_transcoded_ports, scm_transcoded_port): New
functions.
(scm_init_r6rs_ports): Call `initialize_transcoded_ports'.
* module/rnrs/ports.scm (transcoded-port): Remove, this is now
implemented in C.
* test-suite/tests/r6rs-ports.test (8.2.6 Input and output ports): Added a
few tests for `transcoded-port'.
Move the I/O condition types from `(rnrs conditions)', where they were
not exported, to `(rnrs files)', where they are.
* module/rnrs/conditions.scm: Remove definition of I/O condition types.
* module/rnrs/files.scm: Replace references to I/O condition types
inside `(rnrs conditions)' with the actual definitions.
* module/rnrs/io/simple.scm: Don't `@@'-reference the I/O condition types, just
imported them from `(rnrs files)'.
Work towards a more complete implementation of `(rnrs io ports)'.
* 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/io/simple.scm (call-with-input-file,
call-with-output-file): Define these in terms of R6RS procedures to
get correct exception behavior.
---
libguile/r6rs-ports.c | 187 +++++++++++++++++++++++--
module/rnrs.scm | 58 +++------
module/rnrs/conditions.scm | 26 ----
module/rnrs/files.scm | 81 ++++--------
module/rnrs/io/ports.scm | 286 +++++++++++++++++++++++++++++++++-----
module/rnrs/io/simple.scm | 83 +++---------
test-suite/tests/r6rs-ports.test | 31 ++++
7 files changed, 515 insertions(+), 237 deletions(-)
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
index 968b329..d1a4fb1 100644
--- a/libguile/r6rs-ports.c
+++ b/libguile/r6rs-ports.c
@@ -84,6 +84,8 @@ make_bip (SCM bv)
scm_t_port *c_port;
const unsigned long mode_bits = SCM_OPN | SCM_RDNG;
+ scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+
port = scm_new_port_table_entry (bytevector_input_port_type);
/* Prevent BV from being GC'd. */
@@ -100,6 +102,8 @@ make_bip (SCM bv)
/* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
SCM_SET_CELL_TYPE (port, bytevector_input_port_type | mode_bits);
+
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
return port;
}
@@ -305,6 +309,8 @@ make_cbip (SCM read_proc, SCM get_position_proc,
SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc);
SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc);
+ scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
+
port = scm_new_port_table_entry (custom_binary_input_port_type);
/* Attach it the method vector. */
@@ -319,6 +325,8 @@ make_cbip (SCM read_proc, SCM get_position_proc,
/* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
SCM_SET_CELL_TYPE (port, custom_binary_input_port_type | mode_bits);
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+
return port;
}
@@ -751,10 +759,7 @@ SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0,
XXX: Access to a bop's internal buffer is not thread-safe. */
static scm_t_bits bytevector_output_port_type = 0;
-
-SCM_SMOB (bytevector_output_port_procedure,
- "r6rs-bytevector-output-port-procedure",
- 0);
+static scm_t_bits bytevector_output_port_procedure = 0;
#define SCM_GC_BOP "r6rs-bytevector-output-port"
#define SCM_BOP_BUFFER_INITIAL_SIZE 4096
@@ -812,6 +817,8 @@ make_bop (void)
scm_t_bop_buffer *buf;
const unsigned long mode_bits = SCM_OPN | SCM_WRTNG;
+ scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
+
port = scm_new_port_table_entry (bytevector_output_port_type);
buf = (scm_t_bop_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BOP);
@@ -825,11 +832,12 @@ make_bop (void)
/* Mark PORT as open and writable. */
SCM_SET_CELL_TYPE (port, bytevector_output_port_type | mode_bits);
+
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
/* Make the bop procedure. */
- SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure,
- SCM_PACK (port));
-
+ SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure, buf);
+
return (scm_values (scm_list_2 (port, bop_proc)));
}
@@ -886,14 +894,13 @@ bop_seek (SCM port, scm_t_off offset, int whence)
#undef FUNC_NAME
/* Fetch data from a bop. */
-SCM_SMOB_APPLY (bytevector_output_port_procedure,
- bop_proc_apply, 0, 0, 0, (SCM bop_proc))
+static SCM
+bop_proc_apply (SCM bop_proc)
{
- SCM port, bv;
+ SCM bv;
scm_t_bop_buffer *buf, result_buf;
- port = SCM_PACK (SCM_SMOB_DATA (bop_proc));
- buf = SCM_BOP_BUFFER (port);
+ buf = (scm_t_bop_buffer *) SCM_SMOB_DATA (bop_proc);
result_buf = *buf;
bop_buffer_init (buf);
@@ -939,6 +946,12 @@ initialize_bytevector_output_ports (void)
NULL, bop_write);
scm_set_port_seek (bytevector_output_port_type, bop_seek);
+
+ bytevector_output_port_procedure =
+ scm_make_smob_type ("r6rs-bytevector-output-port-procedure", 0);
+
+ scm_set_smob_apply (bytevector_output_port_procedure,
+ bop_proc_apply, 0, 0, 0);
}
\f
@@ -966,6 +979,8 @@ make_cbop (SCM write_proc, SCM get_position_proc,
SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc);
SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc);
+ scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
+
port = scm_new_port_table_entry (custom_binary_output_port_type);
/* Attach it the method vector. */
@@ -978,6 +993,8 @@ make_cbop (SCM write_proc, SCM get_position_proc,
/* Mark PORT as open, writable and unbuffered. */
SCM_SET_CELL_TYPE (port, custom_binary_output_port_type | mode_bits);
+
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
return port;
}
@@ -1062,6 +1079,151 @@ initialize_custom_binary_output_ports (void)
}
\f
+/* Transcoded ports ("tp" for short). */
+static scm_t_bits transcoded_port_type = 0;
+
+#define TP_INPUT_BUFFER_SIZE 4096
+
+#define SCM_TP_BINARY_PORT(_port) SCM_PACK (SCM_STREAM (_port))
+
+static inline SCM
+make_tp (SCM binary_port, unsigned long mode)
+{
+ SCM port;
+ scm_t_port *c_port;
+ const unsigned long mode_bits = SCM_OPN | mode;
+
+ scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
+
+ port = scm_new_port_table_entry (transcoded_port_type);
+
+ SCM_SETSTREAM (port, SCM_UNPACK (binary_port));
+
+ SCM_SET_CELL_TYPE (port, transcoded_port_type | mode_bits);
+
+ if (SCM_INPUT_PORT_P (port))
+ {
+ c_port = SCM_PTAB_ENTRY (port);
+ c_port->read_buf = scm_gc_malloc_pointerless (TP_INPUT_BUFFER_SIZE,
+ "port buffer");
+ c_port->read_pos = c_port->read_end = c_port->read_buf;
+ c_port->read_buf_size = TP_INPUT_BUFFER_SIZE;
+
+ SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~SCM_BUF0);
+ }
+
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+
+ return port;
+}
+
+static void
+tp_write (SCM port, const void *data, size_t size)
+{
+ scm_c_write (SCM_TP_BINARY_PORT (port), data, size);
+}
+
+static int
+tp_fill_input (SCM port)
+{
+ size_t count;
+ scm_t_port *c_port = SCM_PTAB_ENTRY (port);
+ SCM bport = SCM_TP_BINARY_PORT (port);
+ scm_t_port *c_bport = SCM_PTAB_ENTRY (bport);
+
+ /* We can't use scm_c_read() here, since it blocks until the whole
+ block has been read or EOF */
+
+ if (c_bport->rw_active == SCM_PORT_WRITE)
+ scm_force_output (bport);
+
+ if (c_bport->read_pos >= c_bport->read_end)
+ scm_fill_input (bport);
+
+ count = c_bport->read_end - c_bport->read_pos;
+ if (count > c_port->read_buf_size)
+ count = c_port->read_buf_size;
+
+ memcpy (c_port->read_buf, c_bport->read_pos, count);
+ c_bport->read_pos += count;
+
+ if (c_bport->rw_random)
+ c_bport->rw_active = SCM_PORT_READ;
+
+ if (count == 0)
+ return EOF;
+ else
+ {
+ c_port->read_pos = c_port->read_buf;
+ c_port->read_end = c_port->read_buf + count;
+ return *c_port->read_buf;
+ }
+}
+
+static void
+tp_flush (SCM port)
+{
+ SCM binary_port = SCM_TP_BINARY_PORT (port);
+ scm_t_port *c_port = SCM_PTAB_ENTRY (port);
+ size_t count = c_port->write_pos - c_port->write_buf;
+
+ scm_c_write (binary_port, c_port->write_buf, count);
+
+ c_port->write_pos = c_port->write_buf;
+ c_port->rw_active = SCM_PORT_NEITHER;
+
+ scm_force_output (binary_port);
+}
+
+static int
+tp_close (SCM port)
+{
+ if (SCM_OUTPUT_PORT_P (port))
+ tp_flush (port);
+ return scm_is_true (scm_close_port (SCM_TP_BINARY_PORT (port))) ? 0 : -1;
+}
+
+static inline void
+initialize_transcoded_ports (void)
+{
+ transcoded_port_type =
+ scm_make_port_type ("r6rs-transcoded-port", tp_fill_input, tp_write);
+
+ scm_set_port_flush (transcoded_port_type, tp_flush);
+ scm_set_port_close (transcoded_port_type, tp_close);
+}
+
+SCM_DEFINE (scm_transcoded_port,
+ "transcoded-port", 2, 0, 0,
+ (SCM port, SCM transcoder),
+ "")
+#define FUNC_NAME s_scm_transcoded_port
+{
+ SCM codec;
+ SCM result;
+ unsigned long mode = 0;
+
+ SCM_VALIDATE_PORT (SCM_ARG1, port);
+ SCM_VALIDATE_STRUCT (SCM_ARG1, transcoder);
+
+ codec = scm_struct_ref (transcoder, scm_from_int8 (1));
+
+ if (scm_is_true (scm_output_port_p (port)))
+ mode |= SCM_WRTNG;
+ else if (scm_is_true (scm_input_port_p (port)))
+ mode |= SCM_RDNG;
+
+ result = make_tp (port, mode);
+
+ scm_set_port_encoding_x (result, codec);
+
+ /* SCM_CLR_PORT_OPEN_FLAG (port); */
+
+ return result;
+}
+#undef FUNC_NAME
+
+\f
/* Initialization. */
void
@@ -1082,4 +1244,5 @@ scm_init_r6rs_ports (void)
initialize_custom_binary_input_ports ();
initialize_bytevector_output_ports ();
initialize_custom_binary_output_ports ();
+ initialize_transcoded_ports ();
}
diff --git a/module/rnrs.scm b/module/rnrs.scm
index c329aeb..ddc602e 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
@@ -244,45 +258,7 @@
(rnrs enums (6))
(rnrs exceptions (6))
- ;; These i/o conditions are exported by (io simple), (files), and
- ;; should be exported by (ports) but are not yet. Avoid duplicate
- ;; bindings warnings, then, by excluding these bindings from all but
- ;; (io simple).
- (except (rnrs files (6))
- &i/o make-i/o-error i/o-error?
- &i/o-read make-i/o-read-error i/o-read-error?
- &i/o-write make-i/o-write-error i/o-write-error?
-
- &i/o-invalid-position
- make-i/o-invalid-position-error
- i/o-invalid-position-error?
- i/o-error-position
-
- &i/o-filename
- make-i/o-filename-error
- i/o-filename-error?
- i/o-error-filename
-
- &i/o-file-protection
- make-i/o-file-protection-error
- i/o-file-protection-error?
-
- &i/o-file-is-read-only
- make-i/o-file-is-read-only-error
- i/o-file-is-read-only-error?
-
- &i/o-file-already-exists
- make-i/o-file-already-exists-error
- i/o-file-already-exists-error?
-
- &i/o-file-does-not-exist
- make-i/o-file-does-not-exist-error
- i/o-file-does-not-exist-error?
-
- &i/o-port
- make-i/o-port-error
- i/o-port-error?
- i/o-error-port)
+ (rnrs files (6))
(rnrs hashtables (6))
diff --git a/module/rnrs/conditions.scm b/module/rnrs/conditions.scm
index b897221..6885ada 100644
--- a/module/rnrs/conditions.scm
+++ b/module/rnrs/conditions.scm
@@ -229,30 +229,4 @@
(define-condition-type &undefined &violation
make-undefined-violation undefined-violation?)
- ;; Condition types that are used by (rnrs files), (rnrs io ports), and
- ;; (rnrs io simple). These are defined here so as to be easily shareable by
- ;; these three libraries.
-
- (define-condition-type &i/o &error make-i/o-error i/o-error?)
- (define-condition-type &i/o-read &i/o make-i/o-read-error i/o-read-error?)
- (define-condition-type &i/o-write &i/o make-i/o-write-error i/o-write-error?)
- (define-condition-type &i/o-invalid-position
- &i/o make-i/o-invalid-position-error i/o-invalid-position-error?
- (position i/o-error-position))
- (define-condition-type &i/o-filename
- &i/o make-i/o-filename-error i/o-filename-error?
- (filename i/o-error-filename))
- (define-condition-type &i/o-file-protection
- &i/o-filename make-i/o-file-protection-error i/o-file-protection-error?)
- (define-condition-type &i/o-file-is-read-only
- &i/o-file-protection make-i/o-file-is-read-only-error
- i/o-file-is-read-only-error?)
- (define-condition-type &i/o-file-already-exists
- &i/o-filename make-i/o-file-already-exists-error
- i/o-file-already-exists-error?)
- (define-condition-type &i/o-file-does-not-exist
- &i/o-filename make-i/o-file-does-not-exist-error
- i/o-file-does-not-exist-error?)
- (define-condition-type &i/o-port &i/o make-i/o-port-error i/o-port-error?
- (port i/o-error-port))
)
diff --git a/module/rnrs/files.scm b/module/rnrs/files.scm
index e6851d0..447b8b3 100644
--- a/module/rnrs/files.scm
+++ b/module/rnrs/files.scm
@@ -67,59 +67,30 @@
(lambda () (delete-file-internal filename))
(lambda (key . args) (raise (make-i/o-filename-error filename)))))
- (define &i/o (@@ (rnrs conditions) &i/o))
- (define make-i/o-error (@@ (rnrs conditions) make-i/o-error))
- (define i/o-error? (@@ (rnrs conditions) i/o-error?))
-
- (define &i/o-read (@@ (rnrs conditions) &i/o-read))
- (define make-i/o-read-error (@@ (rnrs conditions) make-i/o-read-error))
- (define i/o-read-error? (@@ (rnrs conditions) i/o-read-error?))
-
- (define &i/o-write (@@ (rnrs conditions) &i/o-write))
- (define make-i/o-write-error (@@ (rnrs conditions) make-i/o-write-error))
- (define i/o-write-error? (@@ (rnrs conditions) i/o-write-error?))
-
- (define &i/o-invalid-position (@@ (rnrs conditions) &i/o-invalid-position))
- (define make-i/o-invalid-position-error
- (@@ (rnrs conditions) make-i/o-invalid-position-error))
- (define i/o-invalid-position-error?
- (@@ (rnrs conditions) i/o-invalid-position-error?))
- (define i/o-error-position (@@ (rnrs conditions) i/o-error-position))
-
- (define &i/o-filename (@@ (rnrs conditions) &i/o-filename))
- (define make-i/o-filename-error
- (@@ (rnrs conditions) make-i/o-filename-error))
- (define i/o-filename-error? (@@ (rnrs conditions) i/o-filename-error?))
- (define i/o-error-filename (@@ (rnrs conditions) i/o-error-filename))
-
- (define &i/o-file-protection (@@ (rnrs conditions) &i/o-file-protection))
- (define make-i/o-file-protection-error
- (@@ (rnrs conditions) make-i/o-file-protection-error))
- (define i/o-file-protection-error?
- (@@ (rnrs conditions) i/o-file-protection-error?))
-
- (define &i/o-file-is-read-only (@@ (rnrs conditions) &i/o-file-is-read-only))
- (define make-i/o-file-is-read-only-error
- (@@ (rnrs conditions) make-i/o-file-is-read-only-error))
- (define i/o-file-is-read-only-error?
- (@@ (rnrs conditions) i/o-file-is-read-only-error?))
-
- (define &i/o-file-already-exists
- (@@ (rnrs conditions) &i/o-file-already-exists))
- (define make-i/o-file-already-exists-error
- (@@ (rnrs conditions) make-i/o-file-already-exists-error))
- (define i/o-file-already-exists-error?
- (@@ (rnrs conditions) i/o-file-already-exists-error?))
-
- (define &i/o-file-does-not-exist
- (@@ (rnrs conditions) &i/o-file-does-not-exist))
- (define make-i/o-file-does-not-exist-error
- (@@ (rnrs conditions) make-i/o-file-does-not-exist-error))
- (define i/o-file-does-not-exist-error?
- (@@ (rnrs conditions) i/o-file-does-not-exist-error?))
-
- (define &i/o-port (@@ (rnrs conditions) &i/o-port))
- (define make-i/o-port-error (@@ (rnrs conditions) make-i/o-port-error))
- (define i/o-port-error? (@@ (rnrs conditions) i/o-port-error?))
- (define i/o-error-port (@@ (rnrs conditions) i/o-error-port))
+ ;; Condition types that are used by (rnrs files), (rnrs io ports), and
+ ;; (rnrs io simple). These are defined here so as to be easily shareable by
+ ;; these three libraries.
+
+ (define-condition-type &i/o &error make-i/o-error i/o-error?)
+ (define-condition-type &i/o-read &i/o make-i/o-read-error i/o-read-error?)
+ (define-condition-type &i/o-write &i/o make-i/o-write-error i/o-write-error?)
+ (define-condition-type &i/o-invalid-position
+ &i/o make-i/o-invalid-position-error i/o-invalid-position-error?
+ (position i/o-error-position))
+ (define-condition-type &i/o-filename
+ &i/o make-i/o-filename-error i/o-filename-error?
+ (filename i/o-error-filename))
+ (define-condition-type &i/o-file-protection
+ &i/o-filename make-i/o-file-protection-error i/o-file-protection-error?)
+ (define-condition-type &i/o-file-is-read-only
+ &i/o-file-protection make-i/o-file-is-read-only-error
+ i/o-file-is-read-only-error?)
+ (define-condition-type &i/o-file-already-exists
+ &i/o-filename make-i/o-file-already-exists-error
+ i/o-file-already-exists-error?)
+ (define-condition-type &i/o-file-does-not-exist
+ &i/o-filename make-i/o-file-does-not-exist-error
+ i/o-file-does-not-exist-error?)
+ (define-condition-type &i/o-port &i/o make-i/o-port-error i/o-port-error?
+ (port i/o-error-port))
)
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
index 04dabe6..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.
;;;
@@ -71,9 +186,6 @@
;; So far, we don't support transcoders other than the binary transcoder.
#t)
-(define (transcoded-port port)
- (error "port transcoders are not supported" port))
-
(define (port-position port)
"Return the offset (an integer) indicating where the next octet will be
read from/written to in @var{port}."
@@ -100,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."
@@ -121,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 6afae14..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
@@ -113,61 +114,13 @@
display
write)
(rnrs base (6))
- (rnrs conditions (6)))
-
- (define &i/o (@@ (rnrs conditions) &i/o))
- (define make-i/o-error (@@ (rnrs conditions) make-i/o-error))
- (define i/o-error? (@@ (rnrs conditions) i/o-error?))
-
- (define &i/o-read (@@ (rnrs conditions) &i/o-read))
- (define make-i/o-read-error (@@ (rnrs conditions) make-i/o-read-error))
- (define i/o-read-error? (@@ (rnrs conditions) i/o-read-error?))
-
- (define &i/o-write (@@ (rnrs conditions) &i/o-write))
- (define make-i/o-write-error (@@ (rnrs conditions) make-i/o-write-error))
- (define i/o-write-error? (@@ (rnrs conditions) i/o-write-error?))
-
- (define &i/o-invalid-position (@@ (rnrs conditions) &i/o-invalid-position))
- (define make-i/o-invalid-position-error
- (@@ (rnrs conditions) make-i/o-invalid-position-error))
- (define i/o-invalid-position-error?
- (@@ (rnrs conditions) i/o-invalid-position-error?))
- (define i/o-error-position (@@ (rnrs conditions) i/o-error-position))
-
- (define &i/o-filename (@@ (rnrs conditions) &i/o-filename))
- (define make-i/o-filename-error
- (@@ (rnrs conditions) make-i/o-filename-error))
- (define i/o-filename-error? (@@ (rnrs conditions) i/o-filename-error?))
- (define i/o-error-filename (@@ (rnrs conditions) i/o-error-filename))
-
- (define &i/o-file-protection (@@ (rnrs conditions) &i/o-file-protection))
- (define make-i/o-file-protection-error
- (@@ (rnrs conditions) make-i/o-file-protection-error))
- (define i/o-file-protection-error?
- (@@ (rnrs conditions) i/o-file-protection-error?))
-
- (define &i/o-file-is-read-only (@@ (rnrs conditions) &i/o-file-is-read-only))
- (define make-i/o-file-is-read-only-error
- (@@ (rnrs conditions) make-i/o-file-is-read-only-error))
- (define i/o-file-is-read-only-error?
- (@@ (rnrs conditions) i/o-file-is-read-only-error?))
-
- (define &i/o-file-already-exists
- (@@ (rnrs conditions) &i/o-file-already-exists))
- (define make-i/o-file-already-exists-error
- (@@ (rnrs conditions) make-i/o-file-already-exists-error))
- (define i/o-file-already-exists-error?
- (@@ (rnrs conditions) i/o-file-already-exists-error?))
-
- (define &i/o-file-does-not-exist
- (@@ (rnrs conditions) &i/o-file-does-not-exist))
- (define make-i/o-file-does-not-exist-error
- (@@ (rnrs conditions) make-i/o-file-does-not-exist-error))
- (define i/o-file-does-not-exist-error?
- (@@ (rnrs conditions) i/o-file-does-not-exist-error?))
-
- (define &i/o-port (@@ (rnrs conditions) &i/o-port))
- (define make-i/o-port-error (@@ (rnrs conditions) make-i/o-port-error))
- (define i/o-port-error? (@@ (rnrs conditions) i/o-port-error?))
- (define i/o-error-port (@@ (rnrs conditions) i/o-error-port))
+ (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))
+
)
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index 7d80ed7..7d746ca 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -395,6 +395,14 @@
(put-bytevector port source)
(and (bytevector=? (get-content) source)
(bytevector=? (get-content) (make-bytevector 0))))))
+
+ (pass-if "open-bytevector-output-port [extract after close]"
+ (let-values (((port get-content)
+ (open-bytevector-output-port)))
+ (let ((source (make-bytevector 12345 #xFE)))
+ (put-bytevector port source)
+ (close-port port)
+ (bytevector=? (get-content) source))))
(pass-if "open-bytevector-output-port [put-u8]"
(let-values (((port get-content)
@@ -489,6 +497,29 @@
(not eof?)
(bytevector=? sink source)))))
+(with-test-prefix "8.2.6 Input and output ports"
+ (pass-if "transcoded-port [output]"
+ (let ((s "Hello\nÄÖÜ"))
+ (bytevector=?
+ (string->utf8 s)
+ (call-with-bytevector-output-port
+ (lambda (bv-port)
+ (call-with-port (transcoded-port bv-port (make-transcoder (utf-8-codec)))
+ (lambda (utf8-port)
+ (put-string utf8-port s))))))))
+ (pass-if "transcoded-port [input]"
+ (let ((s "Hello\nÄÖÜ"))
+ (string=?
+ s
+ (get-string-all
+ (transcoded-port (open-bytevector-input-port (string->utf8 s))
+ (make-transcoder (utf-8-codec)))))))
+ (pass-if "transcoded-port [input line]"
+ (string=? "ÄÖÜ"
+ (get-line (transcoded-port
+ (open-bytevector-input-port (string->utf8 "ÄÖÜ\nFooBar"))
+ (make-transcoder (utf-8-codec)))))))
+
;;; Local Variables:
;;; mode: scheme
;;; End:
--
tg: (c05ce90..) t/rnrs-io-ports (depends on: master t/r6rs-exception-print)
[-- Attachment #3: Type: text/plain, Size: 62 bytes --]
Cheers, Rotty
--
Andreas Rottmann -- <http://rotty.yi.org/>
^ permalink raw reply related [flat|nested] 19+ messages in thread
* Re: Some work on the R6RS I/O libraries
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
` (3 more replies)
0 siblings, 4 replies; 19+ messages in thread
From: Ludovic Courtès @ 2010-11-19 23:59 UTC (permalink / raw)
To: guile-devel
Hi Andreas,
I think you intended to make it 4 separate patches, but sent only one.
Can you use ‘git format-patch’, which should give your 4 files, and
attach each one of them?
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 19+ messages in thread
* [PATCH 1/4] Fix missing port-table locking and bytevector output port segfault
2010-11-19 23:59 ` Ludovic Courtès
@ 2010-11-20 17:40 ` 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
` (2 subsequent siblings)
3 siblings, 1 reply; 19+ messages in thread
From: Andreas Rottmann @ 2010-11-20 17:40 UTC (permalink / raw)
To: Guile Development
* libguile/r6rs-ports.c (make_bip, make_cbip, make_bop, make_cbop): Lock
the port table.
* libguile/r6rs-ports.c (make_bop): Let the returned extraction
procedure refer to the port's buffer instead of the port itself. This
fixes a segfault if the port is closed before the extraction procedure
is called.
(bop_proc_apply): Adapt accordingly.
* test-suite/tests/r6rs-ports.test (8.2.10 Output ports): Add testcase
for extraction after close.
---
libguile/r6rs-ports.c | 26 ++++++++++++++++++++------
test-suite/tests/r6rs-ports.test | 8 ++++++++
2 files changed, 28 insertions(+), 6 deletions(-)
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
index 968b329..87aba3d 100644
--- a/libguile/r6rs-ports.c
+++ b/libguile/r6rs-ports.c
@@ -84,6 +84,8 @@ make_bip (SCM bv)
scm_t_port *c_port;
const unsigned long mode_bits = SCM_OPN | SCM_RDNG;
+ scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+
port = scm_new_port_table_entry (bytevector_input_port_type);
/* Prevent BV from being GC'd. */
@@ -100,6 +102,8 @@ make_bip (SCM bv)
/* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
SCM_SET_CELL_TYPE (port, bytevector_input_port_type | mode_bits);
+
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
return port;
}
@@ -305,6 +309,8 @@ make_cbip (SCM read_proc, SCM get_position_proc,
SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc);
SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc);
+ scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
+
port = scm_new_port_table_entry (custom_binary_input_port_type);
/* Attach it the method vector. */
@@ -319,6 +325,8 @@ make_cbip (SCM read_proc, SCM get_position_proc,
/* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
SCM_SET_CELL_TYPE (port, custom_binary_input_port_type | mode_bits);
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+
return port;
}
@@ -812,6 +820,8 @@ make_bop (void)
scm_t_bop_buffer *buf;
const unsigned long mode_bits = SCM_OPN | SCM_WRTNG;
+ scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
+
port = scm_new_port_table_entry (bytevector_output_port_type);
buf = (scm_t_bop_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BOP);
@@ -825,11 +835,12 @@ make_bop (void)
/* Mark PORT as open and writable. */
SCM_SET_CELL_TYPE (port, bytevector_output_port_type | mode_bits);
+
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
/* Make the bop procedure. */
- SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure,
- SCM_PACK (port));
-
+ SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure, buf);
+
return (scm_values (scm_list_2 (port, bop_proc)));
}
@@ -889,11 +900,10 @@ bop_seek (SCM port, scm_t_off offset, int whence)
SCM_SMOB_APPLY (bytevector_output_port_procedure,
bop_proc_apply, 0, 0, 0, (SCM bop_proc))
{
- SCM port, bv;
+ SCM bv;
scm_t_bop_buffer *buf, result_buf;
- port = SCM_PACK (SCM_SMOB_DATA (bop_proc));
- buf = SCM_BOP_BUFFER (port);
+ buf = (scm_t_bop_buffer *) SCM_SMOB_DATA (bop_proc);
result_buf = *buf;
bop_buffer_init (buf);
@@ -966,6 +976,8 @@ make_cbop (SCM write_proc, SCM get_position_proc,
SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc);
SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc);
+ scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
+
port = scm_new_port_table_entry (custom_binary_output_port_type);
/* Attach it the method vector. */
@@ -978,6 +990,8 @@ make_cbop (SCM write_proc, SCM get_position_proc,
/* Mark PORT as open, writable and unbuffered. */
SCM_SET_CELL_TYPE (port, custom_binary_output_port_type | mode_bits);
+
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
return port;
}
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index 7d80ed7..56ecbb6 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -395,6 +395,14 @@
(put-bytevector port source)
(and (bytevector=? (get-content) source)
(bytevector=? (get-content) (make-bytevector 0))))))
+
+ (pass-if "open-bytevector-output-port [extract after close]"
+ (let-values (((port get-content)
+ (open-bytevector-output-port)))
+ (let ((source (make-bytevector 12345 #xFE)))
+ (put-bytevector port source)
+ (close-port port)
+ (bytevector=? (get-content) source))))
(pass-if "open-bytevector-output-port [put-u8]"
(let-values (((port get-content)
--
1.7.2.3
^ permalink raw reply related [flat|nested] 19+ messages in thread
* [PATCH 2/4] Add implementation of "transcoded ports"
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 17:40 ` Andreas Rottmann
2010-11-20 22:52 ` 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 ` [PATCH 4/4] Work towards a more complete implementation of `(rnrs io ports)' Andreas Rottmann
3 siblings, 1 reply; 19+ messages in thread
From: Andreas Rottmann @ 2010-11-20 17:40 UTC (permalink / raw)
To: Guile Development
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1: Type: text/plain; charset=UTF-8, Size: 6538 bytes --]
* libguile/r6rs-ports.c (make_tp, tp_write, tp_fill_input, tp_flush,
tp_close, initialize_transcoded_ports, scm_transcoded_port): New
functions.
(scm_init_r6rs_ports): Call `initialize_transcoded_ports'.
* module/rnrs/ports.scm (transcoded-port): Remove, this is now
implemented in C.
* test-suite/tests/r6rs-ports.test (8.2.6 Input and output ports): Added a
few tests for `transcoded-port'.
---
libguile/r6rs-ports.c | 146 ++++++++++++++++++++++++++++++++++++++
module/rnrs/io/ports.scm | 3 -
test-suite/tests/r6rs-ports.test | 23 ++++++
3 files changed, 169 insertions(+), 3 deletions(-)
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
index 87aba3d..dbb5c80 100644
--- a/libguile/r6rs-ports.c
+++ b/libguile/r6rs-ports.c
@@ -1076,6 +1076,151 @@ initialize_custom_binary_output_ports (void)
}
\f
+/* Transcoded ports ("tp" for short). */
+static scm_t_bits transcoded_port_type = 0;
+
+#define TP_INPUT_BUFFER_SIZE 4096
+
+#define SCM_TP_BINARY_PORT(_port) SCM_PACK (SCM_STREAM (_port))
+
+static inline SCM
+make_tp (SCM binary_port, unsigned long mode)
+{
+ SCM port;
+ scm_t_port *c_port;
+ const unsigned long mode_bits = SCM_OPN | mode;
+
+ scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
+
+ port = scm_new_port_table_entry (transcoded_port_type);
+
+ SCM_SETSTREAM (port, SCM_UNPACK (binary_port));
+
+ SCM_SET_CELL_TYPE (port, transcoded_port_type | mode_bits);
+
+ if (SCM_INPUT_PORT_P (port))
+ {
+ c_port = SCM_PTAB_ENTRY (port);
+ c_port->read_buf = scm_gc_malloc_pointerless (TP_INPUT_BUFFER_SIZE,
+ "port buffer");
+ c_port->read_pos = c_port->read_end = c_port->read_buf;
+ c_port->read_buf_size = TP_INPUT_BUFFER_SIZE;
+
+ SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~SCM_BUF0);
+ }
+
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+
+ return port;
+}
+
+static void
+tp_write (SCM port, const void *data, size_t size)
+{
+ scm_c_write (SCM_TP_BINARY_PORT (port), data, size);
+}
+
+static int
+tp_fill_input (SCM port)
+{
+ size_t count;
+ scm_t_port *c_port = SCM_PTAB_ENTRY (port);
+ SCM bport = SCM_TP_BINARY_PORT (port);
+ scm_t_port *c_bport = SCM_PTAB_ENTRY (bport);
+
+ /* We can't use scm_c_read() here, since it blocks until the whole
+ block has been read or EOF */
+
+ if (c_bport->rw_active == SCM_PORT_WRITE)
+ scm_force_output (bport);
+
+ if (c_bport->read_pos >= c_bport->read_end)
+ scm_fill_input (bport);
+
+ count = c_bport->read_end - c_bport->read_pos;
+ if (count > c_port->read_buf_size)
+ count = c_port->read_buf_size;
+
+ memcpy (c_port->read_buf, c_bport->read_pos, count);
+ c_bport->read_pos += count;
+
+ if (c_bport->rw_random)
+ c_bport->rw_active = SCM_PORT_READ;
+
+ if (count == 0)
+ return EOF;
+ else
+ {
+ c_port->read_pos = c_port->read_buf;
+ c_port->read_end = c_port->read_buf + count;
+ return *c_port->read_buf;
+ }
+}
+
+static void
+tp_flush (SCM port)
+{
+ SCM binary_port = SCM_TP_BINARY_PORT (port);
+ scm_t_port *c_port = SCM_PTAB_ENTRY (port);
+ size_t count = c_port->write_pos - c_port->write_buf;
+
+ scm_c_write (binary_port, c_port->write_buf, count);
+
+ c_port->write_pos = c_port->write_buf;
+ c_port->rw_active = SCM_PORT_NEITHER;
+
+ scm_force_output (binary_port);
+}
+
+static int
+tp_close (SCM port)
+{
+ if (SCM_OUTPUT_PORT_P (port))
+ tp_flush (port);
+ return scm_is_true (scm_close_port (SCM_TP_BINARY_PORT (port))) ? 0 : -1;
+}
+
+static inline void
+initialize_transcoded_ports (void)
+{
+ transcoded_port_type =
+ scm_make_port_type ("r6rs-transcoded-port", tp_fill_input, tp_write);
+
+ scm_set_port_flush (transcoded_port_type, tp_flush);
+ scm_set_port_close (transcoded_port_type, tp_close);
+}
+
+SCM_DEFINE (scm_transcoded_port,
+ "transcoded-port", 2, 0, 0,
+ (SCM port, SCM transcoder),
+ "")
+#define FUNC_NAME s_scm_transcoded_port
+{
+ SCM codec;
+ SCM result;
+ unsigned long mode = 0;
+
+ SCM_VALIDATE_PORT (SCM_ARG1, port);
+ SCM_VALIDATE_STRUCT (SCM_ARG1, transcoder);
+
+ codec = scm_struct_ref (transcoder, scm_from_int8 (1));
+
+ if (scm_is_true (scm_output_port_p (port)))
+ mode |= SCM_WRTNG;
+ else if (scm_is_true (scm_input_port_p (port)))
+ mode |= SCM_RDNG;
+
+ result = make_tp (port, mode);
+
+ scm_set_port_encoding_x (result, codec);
+
+ /* SCM_CLR_PORT_OPEN_FLAG (port); */
+
+ return result;
+}
+#undef FUNC_NAME
+
+\f
/* Initialization. */
void
@@ -1096,4 +1241,5 @@ scm_init_r6rs_ports (void)
initialize_custom_binary_input_ports ();
initialize_bytevector_output_ports ();
initialize_custom_binary_output_ports ();
+ initialize_transcoded_ports ();
}
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
index 04dabe6..ae8d0ea 100644
--- a/module/rnrs/io/ports.scm
+++ b/module/rnrs/io/ports.scm
@@ -71,9 +71,6 @@
;; So far, we don't support transcoders other than the binary transcoder.
#t)
-(define (transcoded-port port)
- (error "port transcoders are not supported" port))
-
(define (port-position port)
"Return the offset (an integer) indicating where the next octet will be
read from/written to in @var{port}."
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index 56ecbb6..7d746ca 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -497,6 +497,29 @@
(not eof?)
(bytevector=? sink source)))))
+(with-test-prefix "8.2.6 Input and output ports"
+ (pass-if "transcoded-port [output]"
+ (let ((s "Hello\nÄÖÜ"))
+ (bytevector=?
+ (string->utf8 s)
+ (call-with-bytevector-output-port
+ (lambda (bv-port)
+ (call-with-port (transcoded-port bv-port (make-transcoder (utf-8-codec)))
+ (lambda (utf8-port)
+ (put-string utf8-port s))))))))
+ (pass-if "transcoded-port [input]"
+ (let ((s "Hello\nÄÖÜ"))
+ (string=?
+ s
+ (get-string-all
+ (transcoded-port (open-bytevector-input-port (string->utf8 s))
+ (make-transcoder (utf-8-codec)))))))
+ (pass-if "transcoded-port [input line]"
+ (string=? "ÄÖÜ"
+ (get-line (transcoded-port
+ (open-bytevector-input-port (string->utf8 "ÄÖÜ\nFooBar"))
+ (make-transcoder (utf-8-codec)))))))
+
;;; Local Variables:
;;; mode: scheme
;;; End:
--
1.7.2.3
^ permalink raw reply related [flat|nested] 19+ messages in thread
* [PATCH 3/4] Reorganize the R6RS I/O condition types
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 17:40 ` [PATCH 2/4] Add implementation of "transcoded ports" Andreas Rottmann
@ 2010-11-20 17:40 ` Andreas Rottmann
2010-11-20 17:40 ` [PATCH 4/4] Work towards a more complete implementation of `(rnrs io ports)' Andreas Rottmann
3 siblings, 0 replies; 19+ messages in thread
From: Andreas Rottmann @ 2010-11-20 17:40 UTC (permalink / raw)
To: Guile Development
Move the I/O condition types from `(rnrs conditions)', where they were
not exported, to `(rnrs files)', where they are.
* module/rnrs/conditions.scm: Remove definition of I/O condition types.
* module/rnrs/files.scm: Replace references to I/O condition types
inside `(rnrs conditions)' with the actual definitions.
* module/rnrs/io/simple.scm: Don't `@@'-reference the I/O condition types, just
imported them from `(rnrs files)'.
---
module/rnrs.scm | 40 +---------------------
module/rnrs/conditions.scm | 26 --------------
module/rnrs/files.scm | 81 ++++++++++++++------------------------------
module/rnrs/io/simple.scm | 60 ++-------------------------------
4 files changed, 30 insertions(+), 177 deletions(-)
diff --git a/module/rnrs.scm b/module/rnrs.scm
index c6f5db1..14218f0 100644
--- a/module/rnrs.scm
+++ b/module/rnrs.scm
@@ -244,45 +244,7 @@
(rnrs enums (6))
(rnrs exceptions (6))
- ;; These i/o conditions are exported by (io simple), (files), and
- ;; should be exported by (ports) but are not yet. Avoid duplicate
- ;; bindings warnings, then, by excluding these bindings from all but
- ;; (io simple).
- (except (rnrs files (6))
- &i/o make-i/o-error i/o-error?
- &i/o-read make-i/o-read-error i/o-read-error?
- &i/o-write make-i/o-write-error i/o-write-error?
-
- &i/o-invalid-position
- make-i/o-invalid-position-error
- i/o-invalid-position-error?
- i/o-error-position
-
- &i/o-filename
- make-i/o-filename-error
- i/o-filename-error?
- i/o-error-filename
-
- &i/o-file-protection
- make-i/o-file-protection-error
- i/o-file-protection-error?
-
- &i/o-file-is-read-only
- make-i/o-file-is-read-only-error
- i/o-file-is-read-only-error?
-
- &i/o-file-already-exists
- make-i/o-file-already-exists-error
- i/o-file-already-exists-error?
-
- &i/o-file-does-not-exist
- make-i/o-file-does-not-exist-error
- i/o-file-does-not-exist-error?
-
- &i/o-port
- make-i/o-port-error
- i/o-port-error?
- i/o-error-port)
+ (rnrs files (6))
(rnrs hashtables (6))
diff --git a/module/rnrs/conditions.scm b/module/rnrs/conditions.scm
index b897221..6885ada 100644
--- a/module/rnrs/conditions.scm
+++ b/module/rnrs/conditions.scm
@@ -229,30 +229,4 @@
(define-condition-type &undefined &violation
make-undefined-violation undefined-violation?)
- ;; Condition types that are used by (rnrs files), (rnrs io ports), and
- ;; (rnrs io simple). These are defined here so as to be easily shareable by
- ;; these three libraries.
-
- (define-condition-type &i/o &error make-i/o-error i/o-error?)
- (define-condition-type &i/o-read &i/o make-i/o-read-error i/o-read-error?)
- (define-condition-type &i/o-write &i/o make-i/o-write-error i/o-write-error?)
- (define-condition-type &i/o-invalid-position
- &i/o make-i/o-invalid-position-error i/o-invalid-position-error?
- (position i/o-error-position))
- (define-condition-type &i/o-filename
- &i/o make-i/o-filename-error i/o-filename-error?
- (filename i/o-error-filename))
- (define-condition-type &i/o-file-protection
- &i/o-filename make-i/o-file-protection-error i/o-file-protection-error?)
- (define-condition-type &i/o-file-is-read-only
- &i/o-file-protection make-i/o-file-is-read-only-error
- i/o-file-is-read-only-error?)
- (define-condition-type &i/o-file-already-exists
- &i/o-filename make-i/o-file-already-exists-error
- i/o-file-already-exists-error?)
- (define-condition-type &i/o-file-does-not-exist
- &i/o-filename make-i/o-file-does-not-exist-error
- i/o-file-does-not-exist-error?)
- (define-condition-type &i/o-port &i/o make-i/o-port-error i/o-port-error?
- (port i/o-error-port))
)
diff --git a/module/rnrs/files.scm b/module/rnrs/files.scm
index e6851d0..447b8b3 100644
--- a/module/rnrs/files.scm
+++ b/module/rnrs/files.scm
@@ -67,59 +67,30 @@
(lambda () (delete-file-internal filename))
(lambda (key . args) (raise (make-i/o-filename-error filename)))))
- (define &i/o (@@ (rnrs conditions) &i/o))
- (define make-i/o-error (@@ (rnrs conditions) make-i/o-error))
- (define i/o-error? (@@ (rnrs conditions) i/o-error?))
-
- (define &i/o-read (@@ (rnrs conditions) &i/o-read))
- (define make-i/o-read-error (@@ (rnrs conditions) make-i/o-read-error))
- (define i/o-read-error? (@@ (rnrs conditions) i/o-read-error?))
-
- (define &i/o-write (@@ (rnrs conditions) &i/o-write))
- (define make-i/o-write-error (@@ (rnrs conditions) make-i/o-write-error))
- (define i/o-write-error? (@@ (rnrs conditions) i/o-write-error?))
-
- (define &i/o-invalid-position (@@ (rnrs conditions) &i/o-invalid-position))
- (define make-i/o-invalid-position-error
- (@@ (rnrs conditions) make-i/o-invalid-position-error))
- (define i/o-invalid-position-error?
- (@@ (rnrs conditions) i/o-invalid-position-error?))
- (define i/o-error-position (@@ (rnrs conditions) i/o-error-position))
-
- (define &i/o-filename (@@ (rnrs conditions) &i/o-filename))
- (define make-i/o-filename-error
- (@@ (rnrs conditions) make-i/o-filename-error))
- (define i/o-filename-error? (@@ (rnrs conditions) i/o-filename-error?))
- (define i/o-error-filename (@@ (rnrs conditions) i/o-error-filename))
-
- (define &i/o-file-protection (@@ (rnrs conditions) &i/o-file-protection))
- (define make-i/o-file-protection-error
- (@@ (rnrs conditions) make-i/o-file-protection-error))
- (define i/o-file-protection-error?
- (@@ (rnrs conditions) i/o-file-protection-error?))
-
- (define &i/o-file-is-read-only (@@ (rnrs conditions) &i/o-file-is-read-only))
- (define make-i/o-file-is-read-only-error
- (@@ (rnrs conditions) make-i/o-file-is-read-only-error))
- (define i/o-file-is-read-only-error?
- (@@ (rnrs conditions) i/o-file-is-read-only-error?))
-
- (define &i/o-file-already-exists
- (@@ (rnrs conditions) &i/o-file-already-exists))
- (define make-i/o-file-already-exists-error
- (@@ (rnrs conditions) make-i/o-file-already-exists-error))
- (define i/o-file-already-exists-error?
- (@@ (rnrs conditions) i/o-file-already-exists-error?))
-
- (define &i/o-file-does-not-exist
- (@@ (rnrs conditions) &i/o-file-does-not-exist))
- (define make-i/o-file-does-not-exist-error
- (@@ (rnrs conditions) make-i/o-file-does-not-exist-error))
- (define i/o-file-does-not-exist-error?
- (@@ (rnrs conditions) i/o-file-does-not-exist-error?))
-
- (define &i/o-port (@@ (rnrs conditions) &i/o-port))
- (define make-i/o-port-error (@@ (rnrs conditions) make-i/o-port-error))
- (define i/o-port-error? (@@ (rnrs conditions) i/o-port-error?))
- (define i/o-error-port (@@ (rnrs conditions) i/o-error-port))
+ ;; Condition types that are used by (rnrs files), (rnrs io ports), and
+ ;; (rnrs io simple). These are defined here so as to be easily shareable by
+ ;; these three libraries.
+
+ (define-condition-type &i/o &error make-i/o-error i/o-error?)
+ (define-condition-type &i/o-read &i/o make-i/o-read-error i/o-read-error?)
+ (define-condition-type &i/o-write &i/o make-i/o-write-error i/o-write-error?)
+ (define-condition-type &i/o-invalid-position
+ &i/o make-i/o-invalid-position-error i/o-invalid-position-error?
+ (position i/o-error-position))
+ (define-condition-type &i/o-filename
+ &i/o make-i/o-filename-error i/o-filename-error?
+ (filename i/o-error-filename))
+ (define-condition-type &i/o-file-protection
+ &i/o-filename make-i/o-file-protection-error i/o-file-protection-error?)
+ (define-condition-type &i/o-file-is-read-only
+ &i/o-file-protection make-i/o-file-is-read-only-error
+ i/o-file-is-read-only-error?)
+ (define-condition-type &i/o-file-already-exists
+ &i/o-filename make-i/o-file-already-exists-error
+ i/o-file-already-exists-error?)
+ (define-condition-type &i/o-file-does-not-exist
+ &i/o-filename make-i/o-file-does-not-exist-error
+ i/o-file-does-not-exist-error?)
+ (define-condition-type &i/o-port &i/o make-i/o-port-error i/o-port-error?
+ (port i/o-error-port))
)
diff --git a/module/rnrs/io/simple.scm b/module/rnrs/io/simple.scm
index 6afae14..17acdf1 100644
--- a/module/rnrs/io/simple.scm
+++ b/module/rnrs/io/simple.scm
@@ -113,61 +113,7 @@
display
write)
(rnrs base (6))
- (rnrs conditions (6)))
-
- (define &i/o (@@ (rnrs conditions) &i/o))
- (define make-i/o-error (@@ (rnrs conditions) make-i/o-error))
- (define i/o-error? (@@ (rnrs conditions) i/o-error?))
-
- (define &i/o-read (@@ (rnrs conditions) &i/o-read))
- (define make-i/o-read-error (@@ (rnrs conditions) make-i/o-read-error))
- (define i/o-read-error? (@@ (rnrs conditions) i/o-read-error?))
-
- (define &i/o-write (@@ (rnrs conditions) &i/o-write))
- (define make-i/o-write-error (@@ (rnrs conditions) make-i/o-write-error))
- (define i/o-write-error? (@@ (rnrs conditions) i/o-write-error?))
-
- (define &i/o-invalid-position (@@ (rnrs conditions) &i/o-invalid-position))
- (define make-i/o-invalid-position-error
- (@@ (rnrs conditions) make-i/o-invalid-position-error))
- (define i/o-invalid-position-error?
- (@@ (rnrs conditions) i/o-invalid-position-error?))
- (define i/o-error-position (@@ (rnrs conditions) i/o-error-position))
-
- (define &i/o-filename (@@ (rnrs conditions) &i/o-filename))
- (define make-i/o-filename-error
- (@@ (rnrs conditions) make-i/o-filename-error))
- (define i/o-filename-error? (@@ (rnrs conditions) i/o-filename-error?))
- (define i/o-error-filename (@@ (rnrs conditions) i/o-error-filename))
-
- (define &i/o-file-protection (@@ (rnrs conditions) &i/o-file-protection))
- (define make-i/o-file-protection-error
- (@@ (rnrs conditions) make-i/o-file-protection-error))
- (define i/o-file-protection-error?
- (@@ (rnrs conditions) i/o-file-protection-error?))
-
- (define &i/o-file-is-read-only (@@ (rnrs conditions) &i/o-file-is-read-only))
- (define make-i/o-file-is-read-only-error
- (@@ (rnrs conditions) make-i/o-file-is-read-only-error))
- (define i/o-file-is-read-only-error?
- (@@ (rnrs conditions) i/o-file-is-read-only-error?))
-
- (define &i/o-file-already-exists
- (@@ (rnrs conditions) &i/o-file-already-exists))
- (define make-i/o-file-already-exists-error
- (@@ (rnrs conditions) make-i/o-file-already-exists-error))
- (define i/o-file-already-exists-error?
- (@@ (rnrs conditions) i/o-file-already-exists-error?))
-
- (define &i/o-file-does-not-exist
- (@@ (rnrs conditions) &i/o-file-does-not-exist))
- (define make-i/o-file-does-not-exist-error
- (@@ (rnrs conditions) make-i/o-file-does-not-exist-error))
- (define i/o-file-does-not-exist-error?
- (@@ (rnrs conditions) i/o-file-does-not-exist-error?))
-
- (define &i/o-port (@@ (rnrs conditions) &i/o-port))
- (define make-i/o-port-error (@@ (rnrs conditions) make-i/o-port-error))
- (define i/o-port-error? (@@ (rnrs conditions) i/o-port-error?))
- (define i/o-error-port (@@ (rnrs conditions) i/o-error-port))
+ (rnrs files (6)) ;for the condition types
+ )
+
)
--
1.7.2.3
^ permalink raw reply related [flat|nested] 19+ messages in thread
* [PATCH 4/4] Work towards a more complete implementation of `(rnrs io ports)'
2010-11-19 23:59 ` Ludovic Courtès
` (2 preceding siblings ...)
2010-11-20 17:40 ` [PATCH 3/4] Reorganize the R6RS I/O condition types Andreas Rottmann
@ 2010-11-20 17:40 ` Andreas Rottmann
3 siblings, 0 replies; 19+ messages in thread
From: Andreas Rottmann @ 2010-11-20 17:40 UTC (permalink / raw)
To: Guile Development
* 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
^ permalink raw reply related [flat|nested] 19+ messages in thread
* Re: [PATCH 1/4] Fix missing port-table locking and bytevector output port segfault
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
0 siblings, 0 replies; 19+ messages in thread
From: Ludovic Courtès @ 2010-11-20 22:43 UTC (permalink / raw)
To: guile-devel
Applied, thanks! (But it's really 2 different patches.)
Ludo'.
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [PATCH 2/4] Add implementation of "transcoded ports"
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
0 siblings, 1 reply; 19+ messages in thread
From: Ludovic Courtès @ 2010-11-20 22:52 UTC (permalink / raw)
To: guile-devel
Hi!
Andreas Rottmann <a.rottmann@gmx.at> writes:
> * libguile/r6rs-ports.c (make_tp, tp_write, tp_fill_input, tp_flush,
> tp_close, initialize_transcoded_ports, scm_transcoded_port): New
> functions.
> (scm_init_r6rs_ports): Call `initialize_transcoded_ports'.
> * module/rnrs/ports.scm (transcoded-port): Remove, this is now
> implemented in C.
> * test-suite/tests/r6rs-ports.test (8.2.6 Input and output ports): Added a
> few tests for `transcoded-port'.
Great! This looks good to me, modulo the minor things below:
> + /* We can't use scm_c_read() here, since it blocks until the whole
> + block has been read or EOF */
Please write it “`scm_c_read'” and add a period at the end.
> +SCM_DEFINE (scm_transcoded_port,
> + "transcoded-port", 2, 0, 0,
> + (SCM port, SCM transcoder),
> + "")
Docstring please. :-)
> + SCM_VALIDATE_STRUCT (SCM_ARG1, transcoder);
This type check is too weak.
> + /* SCM_CLR_PORT_OPEN_FLAG (port); */
Meaning of this comment?
> +(with-test-prefix "8.2.6 Input and output ports"
> + (pass-if "transcoded-port [output]"
> + (let ((s "Hello\n\304\326\334"))
It seems that it’s not actual UTF-8, or maybe the message mangled it
somehow?
> + (call-with-port (transcoded-port bv-port (make-transcoder (utf-8-codec)))
I think you forgot the patch that adds ‘make-transcoder’ and
‘utf-8-codec’. :-)
Can you send an updated patch (or pair of patches)?
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [PATCH 2/4] Add implementation of "transcoded ports"
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
` (3 more replies)
0 siblings, 4 replies; 19+ messages in thread
From: Andreas Rottmann @ 2010-11-21 22:07 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: guile-devel
ludo@gnu.org (Ludovic Courtès) writes:
> Hi!
>
> Andreas Rottmann <a.rottmann@gmx.at> writes:
>
>> * libguile/r6rs-ports.c (make_tp, tp_write, tp_fill_input, tp_flush,
>> tp_close, initialize_transcoded_ports, scm_transcoded_port): New
>> functions.
>> (scm_init_r6rs_ports): Call `initialize_transcoded_ports'.
>> * module/rnrs/ports.scm (transcoded-port): Remove, this is now
>> implemented in C.
>> * test-suite/tests/r6rs-ports.test (8.2.6 Input and output ports): Added a
>> few tests for `transcoded-port'.
>
> Great! This looks good to me, modulo the minor things below:
>
>> + /* We can't use scm_c_read() here, since it blocks until the whole
>> + block has been read or EOF */
>
> Please write it “`scm_c_read'” and add a period at the end.
>
Done.
>> +SCM_DEFINE (scm_transcoded_port,
>> + "transcoded-port", 2, 0, 0,
>> + (SCM port, SCM transcoder),
>> + "")
>
> Docstring please. :-)
>
Added.
>> + SCM_VALIDATE_STRUCT (SCM_ARG1, transcoder);
>
> This type check is too weak.
>
I've restructured the code now so the type checking is done (implictly)
in Scheme.
>> + /* SCM_CLR_PORT_OPEN_FLAG (port); */
>
> Meaning of this comment?
>
I've replaced it with a (hopefully) more meaningful comment.
>> +(with-test-prefix "8.2.6 Input and output ports"
>> + (pass-if "transcoded-port [output]"
>> + (let ((s "Hello\n\304\326\334"))
>
> It seems that it’s not actual UTF-8, or maybe the message mangled it
> somehow?
>
The file has a header which contains this: "coding: iso-8859-1;". The
strings in the source should hence (IIUC) be in latin-1 encoding -- at
least that's what they are in my git.
>> + (call-with-port (transcoded-port bv-port (make-transcoder (utf-8-codec)))
>
> I think you forgot the patch that adds ‘make-transcoder’ and
> ‘utf-8-codec’. :-)
>
As I split the patch into the series, I obviously got the ordering
wrong; sorry. The "transcoded-port" patch is now the last in the
series.
> Can you send an updated patch (or pair of patches)?
>
I'll send the updated series as follow-up to this mail.
Regards, Rotty
--
Andreas Rottmann -- <http://rotty.yi.org/>
^ permalink raw reply [flat|nested] 19+ messages in thread
* [PATCH 1/4] Turn `(rnrs io ports)' into an R6RS library
2010-11-21 22:07 ` Andreas Rottmann
@ 2010-11-21 22:17 ` Andreas Rottmann
2010-11-21 22:17 ` [PATCH 2/4] Reorganize the R6RS I/O condition types Andreas Rottmann
` (2 subsequent siblings)
3 siblings, 0 replies; 19+ messages in thread
From: Andreas Rottmann @ 2010-11-21 22:17 UTC (permalink / raw)
To: Guile Development
* 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)'.
---
module/rnrs/io/ports.scm | 58 +++++++++++++++++++++++----------------------
1 files changed, 30 insertions(+), 28 deletions(-)
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
index 04dabe6..2246049 100644
--- a/module/rnrs/io/ports.scm
+++ b/module/rnrs/io/ports.scm
@@ -26,34 +26,34 @@
;;;
;;; 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?
+
+ ;; 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
+
+ ;; 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)
+ (import (guile))
(load-extension (string-append "libguile-" (effective-version))
"scm_init_r6rs_ports")
@@ -121,4 +121,6 @@ as a string, and a thunk to retrieve the characters associated with that port."
(values port
(lambda () (get-output-string port)))))
+)
+
;;; ports.scm ends here
--
1.7.2.3
^ permalink raw reply related [flat|nested] 19+ messages in thread
* [PATCH 2/4] Reorganize the R6RS I/O condition types
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 ` Andreas Rottmann
2010-11-21 22:17 ` [PATCH 3/4] Work towards a more complete implementation of `(rnrs io ports)' Andreas Rottmann
2010-11-21 22:17 ` [PATCH 4/4] Add implementation of "transcoded ports" Andreas Rottmann
3 siblings, 0 replies; 19+ messages in thread
From: Andreas Rottmann @ 2010-11-21 22:17 UTC (permalink / raw)
To: Guile Development
Move the I/O condition types from `(rnrs conditions)', where they were
not exported, to `(rnrs files)', where they are.
* module/rnrs/conditions.scm: Remove definition of I/O condition types.
* module/rnrs/files.scm: Replace references to I/O condition types
inside `(rnrs conditions)' with the actual definitions.
* module/rnrs/io/simple.scm: Don't `@@'-reference the I/O condition types, just
imported them from `(rnrs files)'.
---
module/rnrs.scm | 40 +---------------------
module/rnrs/conditions.scm | 26 --------------
module/rnrs/files.scm | 81 ++++++++++++++------------------------------
module/rnrs/io/simple.scm | 60 ++-------------------------------
4 files changed, 30 insertions(+), 177 deletions(-)
diff --git a/module/rnrs.scm b/module/rnrs.scm
index c6f5db1..14218f0 100644
--- a/module/rnrs.scm
+++ b/module/rnrs.scm
@@ -244,45 +244,7 @@
(rnrs enums (6))
(rnrs exceptions (6))
- ;; These i/o conditions are exported by (io simple), (files), and
- ;; should be exported by (ports) but are not yet. Avoid duplicate
- ;; bindings warnings, then, by excluding these bindings from all but
- ;; (io simple).
- (except (rnrs files (6))
- &i/o make-i/o-error i/o-error?
- &i/o-read make-i/o-read-error i/o-read-error?
- &i/o-write make-i/o-write-error i/o-write-error?
-
- &i/o-invalid-position
- make-i/o-invalid-position-error
- i/o-invalid-position-error?
- i/o-error-position
-
- &i/o-filename
- make-i/o-filename-error
- i/o-filename-error?
- i/o-error-filename
-
- &i/o-file-protection
- make-i/o-file-protection-error
- i/o-file-protection-error?
-
- &i/o-file-is-read-only
- make-i/o-file-is-read-only-error
- i/o-file-is-read-only-error?
-
- &i/o-file-already-exists
- make-i/o-file-already-exists-error
- i/o-file-already-exists-error?
-
- &i/o-file-does-not-exist
- make-i/o-file-does-not-exist-error
- i/o-file-does-not-exist-error?
-
- &i/o-port
- make-i/o-port-error
- i/o-port-error?
- i/o-error-port)
+ (rnrs files (6))
(rnrs hashtables (6))
diff --git a/module/rnrs/conditions.scm b/module/rnrs/conditions.scm
index b897221..6885ada 100644
--- a/module/rnrs/conditions.scm
+++ b/module/rnrs/conditions.scm
@@ -229,30 +229,4 @@
(define-condition-type &undefined &violation
make-undefined-violation undefined-violation?)
- ;; Condition types that are used by (rnrs files), (rnrs io ports), and
- ;; (rnrs io simple). These are defined here so as to be easily shareable by
- ;; these three libraries.
-
- (define-condition-type &i/o &error make-i/o-error i/o-error?)
- (define-condition-type &i/o-read &i/o make-i/o-read-error i/o-read-error?)
- (define-condition-type &i/o-write &i/o make-i/o-write-error i/o-write-error?)
- (define-condition-type &i/o-invalid-position
- &i/o make-i/o-invalid-position-error i/o-invalid-position-error?
- (position i/o-error-position))
- (define-condition-type &i/o-filename
- &i/o make-i/o-filename-error i/o-filename-error?
- (filename i/o-error-filename))
- (define-condition-type &i/o-file-protection
- &i/o-filename make-i/o-file-protection-error i/o-file-protection-error?)
- (define-condition-type &i/o-file-is-read-only
- &i/o-file-protection make-i/o-file-is-read-only-error
- i/o-file-is-read-only-error?)
- (define-condition-type &i/o-file-already-exists
- &i/o-filename make-i/o-file-already-exists-error
- i/o-file-already-exists-error?)
- (define-condition-type &i/o-file-does-not-exist
- &i/o-filename make-i/o-file-does-not-exist-error
- i/o-file-does-not-exist-error?)
- (define-condition-type &i/o-port &i/o make-i/o-port-error i/o-port-error?
- (port i/o-error-port))
)
diff --git a/module/rnrs/files.scm b/module/rnrs/files.scm
index e6851d0..447b8b3 100644
--- a/module/rnrs/files.scm
+++ b/module/rnrs/files.scm
@@ -67,59 +67,30 @@
(lambda () (delete-file-internal filename))
(lambda (key . args) (raise (make-i/o-filename-error filename)))))
- (define &i/o (@@ (rnrs conditions) &i/o))
- (define make-i/o-error (@@ (rnrs conditions) make-i/o-error))
- (define i/o-error? (@@ (rnrs conditions) i/o-error?))
-
- (define &i/o-read (@@ (rnrs conditions) &i/o-read))
- (define make-i/o-read-error (@@ (rnrs conditions) make-i/o-read-error))
- (define i/o-read-error? (@@ (rnrs conditions) i/o-read-error?))
-
- (define &i/o-write (@@ (rnrs conditions) &i/o-write))
- (define make-i/o-write-error (@@ (rnrs conditions) make-i/o-write-error))
- (define i/o-write-error? (@@ (rnrs conditions) i/o-write-error?))
-
- (define &i/o-invalid-position (@@ (rnrs conditions) &i/o-invalid-position))
- (define make-i/o-invalid-position-error
- (@@ (rnrs conditions) make-i/o-invalid-position-error))
- (define i/o-invalid-position-error?
- (@@ (rnrs conditions) i/o-invalid-position-error?))
- (define i/o-error-position (@@ (rnrs conditions) i/o-error-position))
-
- (define &i/o-filename (@@ (rnrs conditions) &i/o-filename))
- (define make-i/o-filename-error
- (@@ (rnrs conditions) make-i/o-filename-error))
- (define i/o-filename-error? (@@ (rnrs conditions) i/o-filename-error?))
- (define i/o-error-filename (@@ (rnrs conditions) i/o-error-filename))
-
- (define &i/o-file-protection (@@ (rnrs conditions) &i/o-file-protection))
- (define make-i/o-file-protection-error
- (@@ (rnrs conditions) make-i/o-file-protection-error))
- (define i/o-file-protection-error?
- (@@ (rnrs conditions) i/o-file-protection-error?))
-
- (define &i/o-file-is-read-only (@@ (rnrs conditions) &i/o-file-is-read-only))
- (define make-i/o-file-is-read-only-error
- (@@ (rnrs conditions) make-i/o-file-is-read-only-error))
- (define i/o-file-is-read-only-error?
- (@@ (rnrs conditions) i/o-file-is-read-only-error?))
-
- (define &i/o-file-already-exists
- (@@ (rnrs conditions) &i/o-file-already-exists))
- (define make-i/o-file-already-exists-error
- (@@ (rnrs conditions) make-i/o-file-already-exists-error))
- (define i/o-file-already-exists-error?
- (@@ (rnrs conditions) i/o-file-already-exists-error?))
-
- (define &i/o-file-does-not-exist
- (@@ (rnrs conditions) &i/o-file-does-not-exist))
- (define make-i/o-file-does-not-exist-error
- (@@ (rnrs conditions) make-i/o-file-does-not-exist-error))
- (define i/o-file-does-not-exist-error?
- (@@ (rnrs conditions) i/o-file-does-not-exist-error?))
-
- (define &i/o-port (@@ (rnrs conditions) &i/o-port))
- (define make-i/o-port-error (@@ (rnrs conditions) make-i/o-port-error))
- (define i/o-port-error? (@@ (rnrs conditions) i/o-port-error?))
- (define i/o-error-port (@@ (rnrs conditions) i/o-error-port))
+ ;; Condition types that are used by (rnrs files), (rnrs io ports), and
+ ;; (rnrs io simple). These are defined here so as to be easily shareable by
+ ;; these three libraries.
+
+ (define-condition-type &i/o &error make-i/o-error i/o-error?)
+ (define-condition-type &i/o-read &i/o make-i/o-read-error i/o-read-error?)
+ (define-condition-type &i/o-write &i/o make-i/o-write-error i/o-write-error?)
+ (define-condition-type &i/o-invalid-position
+ &i/o make-i/o-invalid-position-error i/o-invalid-position-error?
+ (position i/o-error-position))
+ (define-condition-type &i/o-filename
+ &i/o make-i/o-filename-error i/o-filename-error?
+ (filename i/o-error-filename))
+ (define-condition-type &i/o-file-protection
+ &i/o-filename make-i/o-file-protection-error i/o-file-protection-error?)
+ (define-condition-type &i/o-file-is-read-only
+ &i/o-file-protection make-i/o-file-is-read-only-error
+ i/o-file-is-read-only-error?)
+ (define-condition-type &i/o-file-already-exists
+ &i/o-filename make-i/o-file-already-exists-error
+ i/o-file-already-exists-error?)
+ (define-condition-type &i/o-file-does-not-exist
+ &i/o-filename make-i/o-file-does-not-exist-error
+ i/o-file-does-not-exist-error?)
+ (define-condition-type &i/o-port &i/o make-i/o-port-error i/o-port-error?
+ (port i/o-error-port))
)
diff --git a/module/rnrs/io/simple.scm b/module/rnrs/io/simple.scm
index 6afae14..17acdf1 100644
--- a/module/rnrs/io/simple.scm
+++ b/module/rnrs/io/simple.scm
@@ -113,61 +113,7 @@
display
write)
(rnrs base (6))
- (rnrs conditions (6)))
-
- (define &i/o (@@ (rnrs conditions) &i/o))
- (define make-i/o-error (@@ (rnrs conditions) make-i/o-error))
- (define i/o-error? (@@ (rnrs conditions) i/o-error?))
-
- (define &i/o-read (@@ (rnrs conditions) &i/o-read))
- (define make-i/o-read-error (@@ (rnrs conditions) make-i/o-read-error))
- (define i/o-read-error? (@@ (rnrs conditions) i/o-read-error?))
-
- (define &i/o-write (@@ (rnrs conditions) &i/o-write))
- (define make-i/o-write-error (@@ (rnrs conditions) make-i/o-write-error))
- (define i/o-write-error? (@@ (rnrs conditions) i/o-write-error?))
-
- (define &i/o-invalid-position (@@ (rnrs conditions) &i/o-invalid-position))
- (define make-i/o-invalid-position-error
- (@@ (rnrs conditions) make-i/o-invalid-position-error))
- (define i/o-invalid-position-error?
- (@@ (rnrs conditions) i/o-invalid-position-error?))
- (define i/o-error-position (@@ (rnrs conditions) i/o-error-position))
-
- (define &i/o-filename (@@ (rnrs conditions) &i/o-filename))
- (define make-i/o-filename-error
- (@@ (rnrs conditions) make-i/o-filename-error))
- (define i/o-filename-error? (@@ (rnrs conditions) i/o-filename-error?))
- (define i/o-error-filename (@@ (rnrs conditions) i/o-error-filename))
-
- (define &i/o-file-protection (@@ (rnrs conditions) &i/o-file-protection))
- (define make-i/o-file-protection-error
- (@@ (rnrs conditions) make-i/o-file-protection-error))
- (define i/o-file-protection-error?
- (@@ (rnrs conditions) i/o-file-protection-error?))
-
- (define &i/o-file-is-read-only (@@ (rnrs conditions) &i/o-file-is-read-only))
- (define make-i/o-file-is-read-only-error
- (@@ (rnrs conditions) make-i/o-file-is-read-only-error))
- (define i/o-file-is-read-only-error?
- (@@ (rnrs conditions) i/o-file-is-read-only-error?))
-
- (define &i/o-file-already-exists
- (@@ (rnrs conditions) &i/o-file-already-exists))
- (define make-i/o-file-already-exists-error
- (@@ (rnrs conditions) make-i/o-file-already-exists-error))
- (define i/o-file-already-exists-error?
- (@@ (rnrs conditions) i/o-file-already-exists-error?))
-
- (define &i/o-file-does-not-exist
- (@@ (rnrs conditions) &i/o-file-does-not-exist))
- (define make-i/o-file-does-not-exist-error
- (@@ (rnrs conditions) make-i/o-file-does-not-exist-error))
- (define i/o-file-does-not-exist-error?
- (@@ (rnrs conditions) i/o-file-does-not-exist-error?))
-
- (define &i/o-port (@@ (rnrs conditions) &i/o-port))
- (define make-i/o-port-error (@@ (rnrs conditions) make-i/o-port-error))
- (define i/o-port-error? (@@ (rnrs conditions) i/o-port-error?))
- (define i/o-error-port (@@ (rnrs conditions) i/o-error-port))
+ (rnrs files (6)) ;for the condition types
+ )
+
)
--
1.7.2.3
^ permalink raw reply related [flat|nested] 19+ messages in thread
* [PATCH 3/4] Work towards a more complete implementation of `(rnrs io ports)'
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 ` Andreas Rottmann
2010-11-23 21:13 ` Ludovic Courtès
2010-11-21 22:17 ` [PATCH 4/4] Add implementation of "transcoded ports" Andreas Rottmann
3 siblings, 1 reply; 19+ messages in thread
From: Andreas Rottmann @ 2010-11-21 22:17 UTC (permalink / raw)
To: Guile Development
* 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.
---
module/rnrs.scm | 20 ++++-
module/rnrs/io/ports.scm | 238 ++++++++++++++++++++++++++++++++++++++++++--
module/rnrs/io/simple.scm | 23 +++--
3 files changed, 260 insertions(+), 21 deletions(-)
diff --git a/module/rnrs.scm b/module/rnrs.scm
index 14218f0..e10967b 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 2246049..31c1e29 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 @@
\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)
+ (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")
+
+\f
+;;;
+;;; 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)))))))
+
+\f
+;;;
;;; 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))
+
+
+\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
^ permalink raw reply related [flat|nested] 19+ messages in thread
* [PATCH 4/4] Add implementation of "transcoded ports"
2010-11-21 22:07 ` Andreas Rottmann
` (2 preceding siblings ...)
2010-11-21 22:17 ` [PATCH 3/4] Work towards a more complete implementation of `(rnrs io ports)' Andreas Rottmann
@ 2010-11-21 22:17 ` Andreas Rottmann
2010-11-24 22:29 ` Ludovic Courtès
3 siblings, 1 reply; 19+ messages in thread
From: Andreas Rottmann @ 2010-11-21 22:17 UTC (permalink / raw)
To: Guile Development
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1: Type: text/plain; charset=UTF-8, Size: 6953 bytes --]
* libguile/r6rs-ports.c (make_tp, tp_write, tp_fill_input, tp_flush)
(tp_close, initialize_transcoded_ports, scm_i_make_transcoded_port): New
functions.
(scm_init_r6rs_ports): Call `initialize_transcoded_ports'.
* module/rnrs/ports.scm (transcoded-port): Actually implement,
using `%make-transcoded-port'.
* test-suite/tests/r6rs-ports.test ("8.2.6 Input and output ports"): Added a
few tests for `transcoded-port'.
---
libguile/r6rs-ports.c | 143 ++++++++++++++++++++++++++++++++++++++
module/rnrs/io/ports.scm | 9 ++-
test-suite/tests/r6rs-ports.test | 23 ++++++
3 files changed, 173 insertions(+), 2 deletions(-)
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
index ea6200f..232509c 100644
--- a/libguile/r6rs-ports.c
+++ b/libguile/r6rs-ports.c
@@ -1076,6 +1076,148 @@ initialize_custom_binary_output_ports (void)
}
\f
+/* Transcoded ports ("tp" for short). */
+static scm_t_bits transcoded_port_type = 0;
+
+#define TP_INPUT_BUFFER_SIZE 4096
+
+#define SCM_TP_BINARY_PORT(_port) SCM_PACK (SCM_STREAM (_port))
+
+static inline SCM
+make_tp (SCM binary_port, unsigned long mode)
+{
+ SCM port;
+ scm_t_port *c_port;
+ const unsigned long mode_bits = SCM_OPN | mode;
+
+ scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
+
+ port = scm_new_port_table_entry (transcoded_port_type);
+
+ SCM_SETSTREAM (port, SCM_UNPACK (binary_port));
+
+ SCM_SET_CELL_TYPE (port, transcoded_port_type | mode_bits);
+
+ if (SCM_INPUT_PORT_P (port))
+ {
+ c_port = SCM_PTAB_ENTRY (port);
+ c_port->read_buf = scm_gc_malloc_pointerless (TP_INPUT_BUFFER_SIZE,
+ "port buffer");
+ c_port->read_pos = c_port->read_end = c_port->read_buf;
+ c_port->read_buf_size = TP_INPUT_BUFFER_SIZE;
+
+ SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~SCM_BUF0);
+ }
+
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+
+ return port;
+}
+
+static void
+tp_write (SCM port, const void *data, size_t size)
+{
+ scm_c_write (SCM_TP_BINARY_PORT (port), data, size);
+}
+
+static int
+tp_fill_input (SCM port)
+{
+ size_t count;
+ scm_t_port *c_port = SCM_PTAB_ENTRY (port);
+ SCM bport = SCM_TP_BINARY_PORT (port);
+ scm_t_port *c_bport = SCM_PTAB_ENTRY (bport);
+
+ /* We can't use `scm_c_read' here, since it blocks until the whole
+ block has been read or EOF. */
+
+ if (c_bport->rw_active == SCM_PORT_WRITE)
+ scm_force_output (bport);
+
+ if (c_bport->read_pos >= c_bport->read_end)
+ scm_fill_input (bport);
+
+ count = c_bport->read_end - c_bport->read_pos;
+ if (count > c_port->read_buf_size)
+ count = c_port->read_buf_size;
+
+ memcpy (c_port->read_buf, c_bport->read_pos, count);
+ c_bport->read_pos += count;
+
+ if (c_bport->rw_random)
+ c_bport->rw_active = SCM_PORT_READ;
+
+ if (count == 0)
+ return EOF;
+ else
+ {
+ c_port->read_pos = c_port->read_buf;
+ c_port->read_end = c_port->read_buf + count;
+ return *c_port->read_buf;
+ }
+}
+
+static void
+tp_flush (SCM port)
+{
+ SCM binary_port = SCM_TP_BINARY_PORT (port);
+ scm_t_port *c_port = SCM_PTAB_ENTRY (port);
+ size_t count = c_port->write_pos - c_port->write_buf;
+
+ scm_c_write (binary_port, c_port->write_buf, count);
+
+ c_port->write_pos = c_port->write_buf;
+ c_port->rw_active = SCM_PORT_NEITHER;
+
+ scm_force_output (binary_port);
+}
+
+static int
+tp_close (SCM port)
+{
+ if (SCM_OUTPUT_PORT_P (port))
+ tp_flush (port);
+ return scm_is_true (scm_close_port (SCM_TP_BINARY_PORT (port))) ? 0 : -1;
+}
+
+static inline void
+initialize_transcoded_ports (void)
+{
+ transcoded_port_type =
+ scm_make_port_type ("r6rs-transcoded-port", tp_fill_input, tp_write);
+
+ scm_set_port_flush (transcoded_port_type, tp_flush);
+ scm_set_port_close (transcoded_port_type, tp_close);
+}
+
+SCM_DEFINE (scm_i_make_transcoded_port,
+ "%make-transcoded-port", 1, 0, 0,
+ (SCM port),
+ "Return a new port which reads and writes to @var{port}")
+#define FUNC_NAME s_scm_i_make_transcoded_port
+{
+ SCM result;
+ unsigned long mode = 0;
+
+ SCM_VALIDATE_PORT (SCM_ARG1, port);
+
+ if (scm_is_true (scm_output_port_p (port)))
+ mode |= SCM_WRTNG;
+ else if (scm_is_true (scm_input_port_p (port)))
+ mode |= SCM_RDNG;
+
+ result = make_tp (port, mode);
+
+ /* FIXME: We should actually close `port' "in a special way" here,
+ according to R6RS. As there is no way to do that in Guile without
+ rendering the underlying port unusable for our purposes as well, we
+ just leave it open. */
+
+ return result;
+}
+#undef FUNC_NAME
+
+\f
/* Initialization. */
void
@@ -1096,4 +1238,5 @@ scm_init_r6rs_ports (void)
initialize_custom_binary_input_ports ();
initialize_bytevector_output_ports ();
initialize_custom_binary_output_ports ();
+ initialize_transcoded_ports ();
}
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
index 31c1e29..73271ad 100644
--- a/module/rnrs/io/ports.scm
+++ b/module/rnrs/io/ports.scm
@@ -191,8 +191,13 @@
;; So far, we don't support transcoders other than the binary transcoder.
#t)
-(define (transcoded-port port)
- (error "port transcoders are not supported" port))
+(define (transcoded-port port transcoder)
+ "Return a new textual port based on @var{port}, using
+@var{transcoder} to encode and decode data written to or
+read from its underlying binary port @var{port}."
+ (let ((result (%make-transcoded-port port)))
+ (set-port-encoding! result (transcoder-codec transcoder))
+ result))
(define (port-position port)
"Return the offset (an integer) indicating where the next octet will be
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index 56ecbb6..7d746ca 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -497,6 +497,29 @@
(not eof?)
(bytevector=? sink source)))))
+(with-test-prefix "8.2.6 Input and output ports"
+ (pass-if "transcoded-port [output]"
+ (let ((s "Hello\nÄÖÜ"))
+ (bytevector=?
+ (string->utf8 s)
+ (call-with-bytevector-output-port
+ (lambda (bv-port)
+ (call-with-port (transcoded-port bv-port (make-transcoder (utf-8-codec)))
+ (lambda (utf8-port)
+ (put-string utf8-port s))))))))
+ (pass-if "transcoded-port [input]"
+ (let ((s "Hello\nÄÖÜ"))
+ (string=?
+ s
+ (get-string-all
+ (transcoded-port (open-bytevector-input-port (string->utf8 s))
+ (make-transcoder (utf-8-codec)))))))
+ (pass-if "transcoded-port [input line]"
+ (string=? "ÄÖÜ"
+ (get-line (transcoded-port
+ (open-bytevector-input-port (string->utf8 "ÄÖÜ\nFooBar"))
+ (make-transcoder (utf-8-codec)))))))
+
;;; Local Variables:
;;; mode: scheme
;;; End:
--
1.7.2.3
^ permalink raw reply related [flat|nested] 19+ messages in thread
* Re: [PATCH 3/4] Work towards a more complete implementation of `(rnrs io ports)'
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
0 siblings, 1 reply; 19+ messages in thread
From: Ludovic Courtès @ 2010-11-23 21:13 UTC (permalink / raw)
To: guile-devel
Hi Andreas,
Looks good, but...
Andreas Rottmann <a.rottmann@gmx.at> writes:
> (call-with-port): Don't use `dynamic-wind', as it is against its
> specification in R6RS 8.2.6.
[...]
> (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))))
I don’t see what in §8.2.6 would be against ‘dynamic-wind’, and
<http://www.r6rs.org/formal-comments/comment-197.txt> seems to suggest
that it’s OK.
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [PATCH 3/4] Work towards a more complete implementation of `(rnrs io ports)'
2010-11-23 21:13 ` Ludovic Courtès
@ 2010-11-23 23:44 ` Andreas Rottmann
2010-11-24 20:24 ` Ludovic Courtès
0 siblings, 1 reply; 19+ messages in thread
From: Andreas Rottmann @ 2010-11-23 23:44 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: guile-devel
ludo@gnu.org (Ludovic Courtès) writes:
> Hi Andreas,
>
> Looks good, but...
>
> Andreas Rottmann <a.rottmann@gmx.at> writes:
>
>> (call-with-port): Don't use `dynamic-wind', as it is against its
>> specification in R6RS 8.2.6.
>
> [...]
>
>> (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))))
>
> I don’t see what in §8.2.6 would be against ‘dynamic-wind’,
>
To quote that paragraph about `call-with-port':
,----
| Proc must accept one argument. The call-with-port procedure calls proc
| with port as an argument. If proc returns, port is closed automatically
| and the values returned by proc are returned. If proc does not return,
| port is not closed automatically, except perhaps when it is possible to
| prove that port will never again be used for an input or output
| operation.
`----
I interpreted that the way I did based on the question of what should
happen when `proc' throws an exception (or otherwise invokes a
continuation that makes it leave its current dynamic extent). To me, it
seems that in this case, `proc' does not _return_, and hence the port
should not be closed. Just to clarify, by a procedure "returning", I
understand delivering a value (or values) to its continuation, which
does not happen if the procedure invokes some arbitrary (other)
continuation.
FWIW, `call-with-port' is implemented without `dynamic-wind' in Ikarus,
Ypsilon and Larceny.
> and <http://www.r6rs.org/formal-comments/comment-197.txt> seems to
> suggest that it’s OK.
>
Hmm, to me, the answer given to that comment does not really indicate
whether the proposed implementation using `dynamic-wind' is acceptable
or not (which is unfortunate).
Regards, Rotty
--
Andreas Rottmann -- <http://rotty.yi.org/>
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [PATCH 3/4] Work towards a more complete implementation of `(rnrs io ports)'
2010-11-23 23:44 ` Andreas Rottmann
@ 2010-11-24 20:24 ` Ludovic Courtès
0 siblings, 0 replies; 19+ messages in thread
From: Ludovic Courtès @ 2010-11-24 20:24 UTC (permalink / raw)
To: guile-devel
Hi,
Andreas Rottmann <a.rottmann@gmx.at> writes:
> To quote that paragraph about `call-with-port':
>
> ,----
> | Proc must accept one argument. The call-with-port procedure calls proc
> | with port as an argument. If proc returns, port is closed automatically
> | and the values returned by proc are returned. If proc does not return,
> | port is not closed automatically, except perhaps when it is possible to
> | prove that port will never again be used for an input or output
> | operation.
> `----
>
> I interpreted that the way I did based on the question of what should
> happen when `proc' throws an exception (or otherwise invokes a
> continuation that makes it leave its current dynamic extent). To me, it
> seems that in this case, `proc' does not _return_, and hence the port
> should not be closed. Just to clarify, by a procedure "returning", I
> understand delivering a value (or values) to its continuation, which
> does not happen if the procedure invokes some arbitrary (other)
> continuation.
Oh, yes, makes sense to me now.
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [PATCH 4/4] Add implementation of "transcoded ports"
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
0 siblings, 1 reply; 19+ messages in thread
From: Ludovic Courtès @ 2010-11-24 22:29 UTC (permalink / raw)
To: guile-devel
Hello!
I pushed your patches, thanks!
Now, I’m slightly worried because now (rnrs io ports) /looks/ complete
but isn’t quite complete. :-)
For instance,
- ‘binary-port?’ always returns #t.
- Transcoder EOL styles are silently ignored.
- Not all the transcoder error handling modes are supported.
- Decoding errors are thrown as native Guile exceptions, instead of
R6RS conditions.
So I think “we” (i.e., you ;-)) should either implement the missing
stuff, or raise an exception, or print a warning when the caller asks
for something that’s not implemented (e.g., EOL style != native), or
document the current shortcomings.
What do you think?
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [PATCH 4/4] Add implementation of "transcoded ports"
2010-11-24 22:29 ` Ludovic Courtès
@ 2010-11-25 0:08 ` Andreas Rottmann
2010-11-25 21:15 ` Ludovic Courtès
0 siblings, 1 reply; 19+ messages in thread
From: Andreas Rottmann @ 2010-11-25 0:08 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: guile-devel
ludo@gnu.org (Ludovic Courtès) writes:
> Hello!
>
> I pushed your patches, thanks!
>
Cool!
> Now, I’m slightly worried because now (rnrs io ports) /looks/ complete
> but isn’t quite complete. :-)
>
Indeed.
> For instance,
>
> - ‘binary-port?’ always returns #t.
>
AFAICT, there is currently no strictly correct way to tell binary ports
and textual ports apart -- the closest thing I know about is having a
port encoding of latin-1. Perhaps changing it to test for that would be
at an improvement, although on the other hand, all ports in Guile are
binary ports in the sense that you can do binary I/O operations, such as
`put-bytevector' on them. So without extending the port infrastructure
to support "disjoint" port types, the current implementation of
`binary-port?' is probably the thing closest to the truth.
> - Transcoder EOL styles are silently ignored.
>
> - Not all the transcoder error handling modes are supported.
>
> - Decoding errors are thrown as native Guile exceptions, instead of
> R6RS conditions.
>
Thanks for coming up with this list; I'm sure there's more, but "we"
have to start somewhere ;-).
> So I think “we” (i.e., you ;-)) should either implement the missing
> stuff, or raise an exception, or print a warning when the caller asks
> for something that’s not implemented (e.g., EOL style != native), or
> document the current shortcomings.
>
> What do you think?
>
I'll try to do a mixture of all three approaches -- i.e. implement stuff
as far as I have time and motivation, fall back on warnings, and
document the remaining shortcomings where warnings are not feasible for
some reason. How does that sound?
Regards, Rotty
--
Andreas Rottmann -- <http://rotty.yi.org/>
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [PATCH 4/4] Add implementation of "transcoded ports"
2010-11-25 0:08 ` Andreas Rottmann
@ 2010-11-25 21:15 ` Ludovic Courtès
0 siblings, 0 replies; 19+ messages in thread
From: Ludovic Courtès @ 2010-11-25 21:15 UTC (permalink / raw)
To: guile-devel
Hi Andreas!
Andreas Rottmann <a.rottmann@gmx.at> writes:
> ludo@gnu.org (Ludovic Courtès) writes:
[...]
>> - ‘binary-port?’ always returns #t.
>>
> AFAICT, there is currently no strictly correct way to tell binary ports
> and textual ports apart -- the closest thing I know about is having a
> port encoding of latin-1. Perhaps changing it to test for that would be
> at an improvement, although on the other hand, all ports in Guile are
> binary ports in the sense that you can do binary I/O operations, such as
> `put-bytevector' on them. So without extending the port infrastructure
> to support "disjoint" port types, the current implementation of
> `binary-port?' is probably the thing closest to the truth.
True. We know that a transcoded port with one of the textual codecs is
textual, but we can never know if it’s “binary-only”.
I’m not sure how much of a problem it is for R6RS programs. Actually I
cannot imagine how a program would make use of it, other than for
type-checking purposes. Thoughts?
[...]
>> So I think “we” (i.e., you ;-)) should either implement the missing
>> stuff, or raise an exception, or print a warning when the caller asks
>> for something that’s not implemented (e.g., EOL style != native), or
>> document the current shortcomings.
>>
>
>> What do you think?
>>
> I'll try to do a mixture of all three approaches -- i.e. implement stuff
> as far as I have time and motivation, fall back on warnings, and
> document the remaining shortcomings where warnings are not feasible for
> some reason. How does that sound?
Good! :-)
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 19+ messages in thread
end of thread, other threads:[~2010-11-25 21:15 UTC | newest]
Thread overview: 19+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
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 ` [PATCH 4/4] Work towards a more complete implementation of `(rnrs io ports)' Andreas Rottmann
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).