[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-105-gc
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-105-gc0f6c16 |
|
Date: |
Tue, 30 Nov 2010 21:43:55 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=c0f6c1638bb920d5cf5ec3210d91bc9fb0c70319
The branch, master has been updated
via c0f6c1638bb920d5cf5ec3210d91bc9fb0c70319 (commit)
via 43ecaffc2f564dbb03af446671097a548378df82 (commit)
via d4b8163784c4764b5b5ecd3c5ac3892cc5b46e64 (commit)
via 1044537dff91146ed17f13cfa8d1eca5f92f4307 (commit)
via a5484153b83b04f8e9bbe392b97904e9493da44e (commit)
via 50851f1d182f41ff4fc3a5f2c967231575da4d94 (commit)
via baa5705ca726c261c9aa37d3b9af52f3949690ac (commit)
from 644c5165ee449a3beccadeb969e02746954703ee (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit c0f6c1638bb920d5cf5ec3210d91bc9fb0c70319
Author: Andreas Rottmann <address@hidden>
Date: Thu Nov 25 23:03:12 2010 +0100
Some tweaks to the R6RS support
* module/rnrs/base.scm (error, assert): Define -- they were missing.
(assertion-violation): Properly treat a #f `who' argument.
* module/rnrs/conditions.scm (condition): Use `assertion-violation'
instead of the undefined `raise'.
(define-condition-type): Fix for multiple fields.
* test-suite/tests/r6rs-conditions.test: Test accessors of a
multiple-field condition. Also import `(rnrs base)' to allow
stand-alone running of the tests; apparently the `@' references
scattered throughout the R6RS modules make the libraries sensitive to
their load order -- for instance, trying to load `(rnrs conditions)'
before `(rnrs base)' is loaded fails.
* module/rnrs/records/inspection.scm: Use `assertion-violation' instead
of an explicit `raise'.
* module/rnrs/records/syntactic.scm (process-fields): Use
`syntax-violation' instead of bogus invocations of `error'.
commit 43ecaffc2f564dbb03af446671097a548378df82
Author: Ludovic Courtès <address@hidden>
Date: Wed Nov 24 23:38:01 2010 +0100
Fix `regexp.test' when the "en_US.utf8" locale isn't available.
* test-suite/tests/regexp.test ("nonascii locales"): Move `with-locale'
within the body of `pass-if' so that `unresolved' is caught.
commit d4b8163784c4764b5b5ecd3c5ac3892cc5b46e64
Author: Ludovic Courtès <address@hidden>
Date: Wed Nov 24 23:01:50 2010 +0100
Honor R6RS transcoder error handling modes, when possible.
* module/rnrs/io/ports.scm (transcoded-port): Change RESULT's conversion
strategy based on TRANSCODER's error-handling mode.
* test-suite/tests/r6rs-ports.test ("8.2.6 Input and output
ports")["transcoded-port [error handling mode = raise]",
"transcoded-port [error handling mode = replace]"]: New tests.
commit 1044537dff91146ed17f13cfa8d1eca5f92f4307
Author: Andreas Rottmann <address@hidden>
Date: Sun Nov 21 23:17:54 2010 +0100
Add implementation of "transcoded ports"
* 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'.
Signed-off-by: Ludovic Courtès <address@hidden>
commit a5484153b83b04f8e9bbe392b97904e9493da44e
Author: Andreas Rottmann <address@hidden>
Date: Sun Nov 21 23:17:53 2010 +0100
Work towards a more complete implementation of `(rnrs io ports)'
* module/rnrs/io/ports.scm: (file-options, buffer-mode, eol-style)
(error-handling-mode, make-transcoder, native-transcoder)
(latin-1-codec, utf-8-codec, utf-16-codec)
(call-with-bytevector-output-port, open-file-input-port)
(open-file-output-port, make-custom-textual-output-port)
(flush-output-port, put-char, put-datum, put-string, get-char)
(get-datum, get-line, get-string-all, lookahead-char)
(standard-input-port, standard-output-port, standard-error-port):
Define all of these.
(call-with-port): Don't use `dynamic-wind', as it is against its
specification in R6RS 8.2.6.
* module/rnrs.scm: Export procedures added.
* module/rnrs/io/simple.scm (call-with-input-file)
(call-with-output-file): Define these in terms of R6RS procedures to
get correct exception behavior.
Signed-off-by: Ludovic Courtès <address@hidden>
commit 50851f1d182f41ff4fc3a5f2c967231575da4d94
Author: Andreas Rottmann <address@hidden>
Date: Sun Nov 21 23:17:52 2010 +0100
Reorganize the R6RS I/O condition types
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)'.
Signed-off-by: Ludovic Courtès <address@hidden>
commit baa5705ca726c261c9aa37d3b9af52f3949690ac
Author: Andreas Rottmann <address@hidden>
Date: Sun Nov 21 23:17:51 2010 +0100
Turn `(rnrs io ports)' into an R6RS library
* 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)'.
Signed-off-by: Ludovic Courtès <address@hidden>
-----------------------------------------------------------------------
Summary of changes:
libguile/r6rs-ports.c | 143 +++++++++++++++
module/rnrs.scm | 60 ++-----
module/rnrs/base.scm | 30 +++-
module/rnrs/conditions.scm | 41 +----
module/rnrs/files.scm | 81 +++------
module/rnrs/io/ports.scm | 305 +++++++++++++++++++++++++++++----
module/rnrs/io/simple.scm | 83 ++-------
module/rnrs/records/inspection.scm | 30 ++--
module/rnrs/records/syntactic.scm | 10 +-
test-suite/tests/r6rs-conditions.test | 14 ++-
test-suite/tests/r6rs-ports.test | 57 ++++++-
test-suite/tests/regexp.test | 6 +-
12 files changed, 592 insertions(+), 268 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)
}
+/* 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
+
+
/* 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.scm b/module/rnrs.scm
index c6f5db1..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
@@ -244,45 +260,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/base.scm b/module/rnrs/base.scm
index 6320420..a6ae1b9 100644
--- a/module/rnrs/base.scm
+++ b/module/rnrs/base.scm
@@ -73,7 +73,7 @@
let-syntax letrec-syntax
syntax-rules identifier-syntax)
- (import (rename (guile)
+ (import (rename (except (guile) error raise)
(quotient div)
(modulo mod)
(exact->inexact inexact)
@@ -137,6 +137,8 @@
(@ (rnrs exceptions) raise))
(define condition
(@ (rnrs conditions) condition))
+ (define make-error
+ (@ (rnrs conditions) make-error))
(define make-assertion-violation
(@ (rnrs conditions) make-assertion-violation))
(define make-who-condition
@@ -145,12 +147,28 @@
(@ (rnrs conditions) make-message-condition))
(define make-irritants-condition
(@ (rnrs conditions) make-irritants-condition))
+
+ (define (error who message . irritants)
+ (raise (apply condition
+ (append (list (make-error))
+ (if who (list (make-who-condition who)) '())
+ (list (make-message-condition message)
+ (make-irritants-condition irritants))))))
(define (assertion-violation who message . irritants)
- (raise (condition
- (make-assertion-violation)
- (make-who-condition who)
- (make-message-condition message)
- (make-irritants-condition irritants))))
+ (raise (apply condition
+ (append (list (make-assertion-violation))
+ (if who (list (make-who-condition who)) '())
+ (list (make-message-condition message)
+ (make-irritants-condition irritants))))))
+
+ (define-syntax assert
+ (syntax-rules ()
+ ((_ expression)
+ (if (not expression)
+ (raise (condition
+ (make-assertion-violation)
+ (make-message-condition
+ (format #f "assertion failed: ~s" 'expression))))))))
)
diff --git a/module/rnrs/conditions.scm b/module/rnrs/conditions.scm
index b897221..959411b 100644
--- a/module/rnrs/conditions.scm
+++ b/module/rnrs/conditions.scm
@@ -115,7 +115,7 @@
(define (flatten cond)
(if (compound-condition? cond) (simple-conditions cond) (list cond)))
(or (for-all condition? conditions)
- (raise (make-assertion-violation)))
+ (assertion-violation 'condition "non-condition argument" conditions))
(if (or (null? conditions) (> (length conditions) 1))
(make-compound-condition (apply append (map flatten conditions)))
(car conditions))))
@@ -128,9 +128,7 @@
((transform-fields
(syntax-rules ()
((_ (f a) . rest)
- (cons '(immutable f a) (transform-fields rest)))
- ((_ ((f a))) '((immutable f a)))
- ((_ ()) '())
+ (cons '(immutable f a) (transform-fields . rest)))
((_) '())))
(generate-accessors
@@ -140,13 +138,8 @@
(condition-accessor
condition-type
(record-accessor condition-type counter)))
- (generate-accessors (+ counter 1) rest)))
- ((_ counter ((f a)))
- (define a
- (condition-accessor
- condition-type (record-accessor condition-type counter))))
- ((_ counter ()) (begin))
- ((_ counter) (begin)))))
+ (generate-accessors (+ counter 1) . rest)))
+ ((_ counter) (begin)))))
(begin
(define condition-type
(make-record-type-descriptor
@@ -229,30 +222,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..854ea09 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,78 @@
;;;
+;;; Auxiliary types
+;;;
+
+(define-enumeration file-option
+ (no-create no-fail no-truncate)
+ file-options)
+
+(define-enumeration buffer-mode
+ (none line block)
+ buffer-modes)
+
+(define (buffer-mode? symbol)
+ (enum-set-member? symbol (enum-set-universe (buffer-modes))))
+
+(define-enumeration eol-style
+ (lf cr crlf nel crnel ls)
+ eol-styles)
+
+(define (native-eol-style)
+ (eol-style lf))
+
+(define-enumeration error-handling-mode
+ (ignore raise replace)
+ error-handling-modes)
+
+(define-record-type (transcoder %make-transcoder transcoder?)
+ (fields codec eol-style error-handling-mode))
+
+(define* (make-transcoder codec
+ #:optional
+ (eol-style (native-eol-style))
+ (handling-mode (error-handling-mode replace)))
+ (%make-transcoder codec eol-style handling-mode))
+
+(define (native-transcoder)
+ (make-transcoder (or (fluid-ref %default-port-encoding)
+ (latin-1-codec))))
+
+(define (latin-1-codec)
+ "ISO-8859-1")
+
+(define (utf-8-codec)
+ "UTF-8")
+
+(define (utf-16-codec)
+ "UTF-16")
+
+
+;;;
+;;; Internal helpers
+;;;
+
+(define (with-i/o-filename-conditions filename thunk)
+ (catch 'system-error
+ thunk
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (let ((construct-condition
+ (cond ((= errno EACCES)
+ make-i/o-file-protection-error)
+ ((= errno EEXIST)
+ make-i/o-file-already-exists-error)
+ ((= errno ENOENT)
+ make-i/o-file-does-not-exist-error)
+ ((= errno EROFS)
+ make-i/o-file-is-read-only-error)
+ (else
+ make-i/o-filename-error))))
+ (raise (construct-condition filename)))))))
+
+
+;;;
;;; Input and output ports.
;;;
@@ -71,8 +191,21 @@
;; 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
address@hidden 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))
+ (case (transcoder-error-handling-mode transcoder)
+ ((raise)
+ (set-port-conversion-strategy! result 'error))
+ ((replace)
+ (set-port-conversion-strategy! result 'substitute))
+ (else
+ (error "unsupported error handling mode"
+ (transcoder-error-handling-mode transcoder))))
+ result))
(define (port-position port)
"Return the offset (an integer) indicating where the next octet will be
@@ -100,19 +233,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 +268,88 @@ as a string, and a thunk to retrieve the characters
associated with that port."
(values port
(lambda () (get-output-string port)))))
+(define* (open-file-output-port filename
+ #:optional
+ (file-options (file-options))
+ (buffer-mode (buffer-mode block))
+ maybe-transcoder)
+ (let* ((flags (logior O_WRONLY
+ (if (enum-set-member? 'no-create file-options)
+ 0
+ O_CREAT)
+ (if (enum-set-member? 'no-truncate file-options)
+ 0
+ O_TRUNC)))
+ (port (with-i/o-filename-conditions filename
+ (lambda () (open filename flags)))))
+ (cond (maybe-transcoder
+ (set-port-encoding! port (transcoder-codec maybe-transcoder))))
+ port))
+
+(define (call-with-string-output-port proc)
+ "Call @var{proc}, passing it a string output port. When @var{proc} returns,
+return the characters accumulated in that port."
+ (let ((port (open-output-string)))
+ (proc port)
+ (get-output-string port)))
+
+(define (make-custom-textual-output-port id
+ write!
+ get-position
+ set-position!
+ close)
+ (make-soft-port (vector (lambda (c) (write! (string c) 0 1))
+ (lambda (s) (write! s 0 (string-length s)))
+ #f ;flush
+ #f ;read character
+ close)
+ "w"))
+
+(define (flush-output-port port)
+ (force-output port))
+
+(define (put-char port char)
+ (write-char char port))
+
+(define (put-datum port datum)
+ (write datum port))
+
+(define* (put-string port s #:optional start count)
+ (cond ((not (string? s))
+ (assertion-violation 'put-string "expected string" s))
+ ((and start count)
+ (display (substring/shared s start (+ start count)) port))
+ (start
+ (display (substring/shared s start (string-length s)) port))
+ (else
+ (display s port))))
+
+(define (get-char port)
+ (read-char port))
+
+(define (get-datum port)
+ (read port))
+
+(define (get-line port)
+ (read-line port 'trim))
+
+(define (get-string-all port)
+ (read-delimited "" port 'concat))
+
+(define (lookahead-char port)
+ (peek-char port))
+
+
+
+(define (standard-input-port)
+ (dup->inport 0))
+
+(define (standard-output-port)
+ (dup->outport 1))
+
+(define (standard-error-port)
+ (dup->outport 2))
+
+)
+
;;; ports.scm ends here
diff --git a/module/rnrs/io/simple.scm b/module/rnrs/io/simple.scm
index 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/module/rnrs/records/inspection.scm
b/module/rnrs/records/inspection.scm
index 315ef0c..68b78a9 100644
--- a/module/rnrs/records/inspection.scm
+++ b/module/rnrs/records/inspection.scm
@@ -30,8 +30,6 @@
record-field-mutable?)
(import (rnrs arithmetic bitwise (6))
(rnrs base (6))
- (rnrs conditions (6))
- (rnrs exceptions (6))
(rnrs records procedural (6))
(only (guile) struct-ref struct-vtable vtable-index-layout @@))
@@ -55,25 +53,29 @@
(or (and (record-internal? record)
(let ((rtd (struct-vtable record)))
(and (not (struct-ref rtd rtd-index-opaque?)) rtd)))
- (raise (make-assertion-violation))))
+ (assertion-violation 'record-rtd "not a record" record)))
- (define (ensure-rtd rtd)
- (if (not (record-type-descriptor? rtd)) (raise
(make-assertion-violation))))
+ (define (guarantee-rtd who rtd)
+ (if (record-type-descriptor? rtd)
+ rtd
+ (assertion-violation who "not a record type descriptor" rtd)))
(define (record-type-name rtd)
- (ensure-rtd rtd) (struct-ref rtd rtd-index-name))
+ (struct-ref (guarantee-rtd 'record-type-name rtd) rtd-index-name))
(define (record-type-parent rtd)
- (ensure-rtd rtd) (struct-ref rtd rtd-index-parent))
- (define (record-type-uid rtd) (ensure-rtd rtd) (struct-ref rtd
rtd-index-uid))
+ (struct-ref (guarantee-rtd 'record-type-parent rtd) rtd-index-parent))
+ (define (record-type-uid rtd)
+ (struct-ref (guarantee-rtd 'record-type-uid rtd) rtd-index-uid))
(define (record-type-generative? rtd)
- (ensure-rtd rtd) (not (record-type-uid rtd)))
+ (not (record-type-uid (guarantee-rtd 'record-type-generative? rtd))))
(define (record-type-sealed? rtd)
- (ensure-rtd rtd) (struct-ref rtd rtd-index-sealed?))
+ (struct-ref (guarantee-rtd 'record-type-sealed? rtd) rtd-index-sealed?))
(define (record-type-opaque? rtd)
- (ensure-rtd rtd) (struct-ref rtd rtd-index-opaque?))
+ (struct-ref (guarantee-rtd 'record-type-opaque? rtd) rtd-index-opaque?))
(define (record-type-field-names rtd)
- (ensure-rtd rtd) (struct-ref rtd rtd-index-field-names))
+ (struct-ref (guarantee-rtd 'record-type-field-names rtd)
rtd-index-field-names))
(define (record-field-mutable? rtd k)
- (ensure-rtd rtd)
- (bitwise-bit-set? (struct-ref rtd rtd-index-field-bit-field) k))
+ (bitwise-bit-set? (struct-ref (guarantee-rtd 'record-field-mutable? rtd)
+ rtd-index-field-bit-field)
+ k))
)
diff --git a/module/rnrs/records/syntactic.scm
b/module/rnrs/records/syntactic.scm
index 5070212..6431fcf 100644
--- a/module/rnrs/records/syntactic.scm
+++ b/module/rnrs/records/syntactic.scm
@@ -85,14 +85,16 @@
record-name-str "-" (symbol->string field-name) "-set!")))
(define (f x)
+ (define (lose)
+ (syntax-violation 'define-record-type "invalid field specifier" x))
(cond ((symbol? x) (list 'immutable x (guess-accessor-name x) #f))
- ((not (list? x)) (error))
+ ((not (list? x)) (lose))
((eq? (car x) 'immutable)
(cons 'immutable
(case (length x)
((2) (list (cadr x) (guess-accessor-name (cadr x)) #f))
((3) (list (cadr x) (caddr x) #f))
- (else (error)))))
+ (else (lose)))))
((eq? (car x) 'mutable)
(cons 'mutable
(case (length x)
@@ -100,8 +102,8 @@
(guess-accessor-name (cadr x))
(guess-mutator-name (cadr x))))
((4) (cdr x))
- (else (error)))))
- (else (error))))
+ (else (lose)))))
+ (else (lose))))
(map f fields))
(define-syntax define-record-type0
diff --git a/test-suite/tests/r6rs-conditions.test
b/test-suite/tests/r6rs-conditions.test
index 9432f37..7480b9c 100644
--- a/test-suite/tests/r6rs-conditions.test
+++ b/test-suite/tests/r6rs-conditions.test
@@ -18,11 +18,16 @@
(define-module (test-suite test-rnrs-conditions)
+ :use-module ((rnrs base) :version (6))
:use-module ((rnrs conditions) :version (6))
:use-module (test-suite lib))
(define-condition-type &a &condition make-a-condition a-condition? (foo a-foo))
(define-condition-type &b &condition make-b-condition b-condition? (bar b-bar))
+(define-condition-type &c &condition make-c-condition c-condition?
+ (baz c-baz)
+ (qux c-qux)
+ (frobotz c-frobotz))
(with-test-prefix "condition?"
(pass-if "condition? is #t for simple conditions"
@@ -96,4 +101,11 @@
(with-test-prefix "define-condition-type"
(pass-if "define-condition-type produces proper accessors"
(let ((c (condition (make-a-condition 'foo) (make-b-condition 'bar))))
- (and (eq? (a-foo c) 'foo) (eq? (b-bar c) 'bar)))))
+ (and (eq? (a-foo c) 'foo) (eq? (b-bar c) 'bar))))
+ (pass-if "define-condition-type works for multiple fields"
+ (let ((c (condition (make-a-condition 'foo)
+ (make-c-condition 1 2 3))))
+ (and (eq? (a-foo c) 'foo)
+ (= (c-baz c) 1)
+ (= (c-qux c) 2)
+ (= (c-frobotz c) 3)))))
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index 56ecbb6..8d93f62 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -18,11 +18,11 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
(define-module (test-io-ports)
- :use-module (test-suite lib)
- :use-module (srfi srfi-1)
- :use-module (srfi srfi-11)
- :use-module (rnrs io ports)
- :use-module (rnrs bytevectors))
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (rnrs io ports)
+ #:use-module (rnrs bytevectors))
;;; All these tests assume Guile 1.8's port system, where characters are
;;; treated as octets.
@@ -497,6 +497,53 @@
(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))))))
+
+ (pass-if "transcoded-port [error handling mode = raise]"
+ (let* ((t (make-transcoder (utf-8-codec) (native-eol-style)
+ (error-handling-mode raise)))
+ (b (open-bytevector-input-port #vu8(255 2 1)))
+ (tp (transcoded-port b t)))
+ ;; FIXME: Should be (guard (c ((i/o-decoding-error? c) #t)) ...).
+ (catch 'encoding-error
+ (lambda ()
+ (get-line tp)
+ #f)
+ (lambda _
+ #t))))
+
+ (pass-if "transcoded-port [error handling mode = replace]"
+ (let* ((t (make-transcoder (utf-8-codec) (native-eol-style)
+ (error-handling-mode replace)))
+ (b (open-bytevector-input-port #vu8(255 1 2 3 103 110 117)))
+ (tp (transcoded-port b t)))
+ (string-suffix? "gnu" (get-line tp)))))
+
;;; Local Variables:
;;; mode: scheme
;;; End:
diff --git a/test-suite/tests/regexp.test b/test-suite/tests/regexp.test
index 1b58789..f405df4 100644
--- a/test-suite/tests/regexp.test
+++ b/test-suite/tests/regexp.test
@@ -267,8 +267,8 @@
'post))
(with-test-prefix "nonascii locales"
- (with-locale "en_US.utf8"
- ;; bug 31650
- (pass-if "match structures refer to char offsets"
+ (pass-if "match structures refer to char offsets"
+ (with-locale "en_US.utf8"
+ ;; bug #31650
(equal? (match:substring (string-match ".*" "calçot") 0)
"calçot"))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-13-105-gc0f6c16,
Andy Wingo <=