summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-05-25 10:32:19 +0200
committerAndy Wingo <wingo@pobox.com>2011-05-25 10:32:19 +0200
commita099c8d971c1d5b32e00f25469b36ce45fd4d8c7 (patch)
tree350e16d9e9e01c95c366aa44ba31d03bf57ac83c
parent9ec1573d2b9463043df79b9a2cb30acc6afaeaaa (diff)
parent7ad0737de9b7bbb5f4f938518b4905b526d13ca6 (diff)
downloadguile-a099c8d971c1d5b32e00f25469b36ce45fd4d8c7.tar.gz
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts: libguile/procprop.c
-rw-r--r--doc/ref/api-debug.texi9
-rw-r--r--doc/ref/api-evaluation.texi14
-rw-r--r--doc/ref/api-io.texi8
-rw-r--r--doc/ref/repl-modules.texi36
-rw-r--r--libguile/Makefile.am11
-rw-r--r--libguile/filesys.c2
-rw-r--r--libguile/goops.c12
-rw-r--r--libguile/procprop.c10
-rw-r--r--libguile/read.c119
-rw-r--r--libguile/smob.c15
-rw-r--r--libguile/srcprop.c59
-rw-r--r--libguile/srcprop.h4
-rw-r--r--libguile/stime.c10
-rw-r--r--libguile/symbols.c19
-rw-r--r--module/ice-9/boot-9.scm6
-rw-r--r--module/oop/goops.scm152
-rw-r--r--module/rnrs/io/ports.scm78
-rw-r--r--test-suite/standalone/Makefile.am6
-rwxr-xr-xtest-suite/standalone/test-import-order31
-rw-r--r--test-suite/standalone/test-import-order-a.scm4
-rw-r--r--test-suite/standalone/test-import-order-b.scm4
-rw-r--r--test-suite/standalone/test-import-order-c.scm4
-rw-r--r--test-suite/standalone/test-import-order-d.scm4
-rw-r--r--test-suite/tests/r6rs-ports.test136
24 files changed, 470 insertions, 283 deletions
diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi
index 765b4ad8d..bdb616656 100644
--- a/doc/ref/api-debug.texi
+++ b/doc/ref/api-debug.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2010
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2010, 2011
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -645,10 +645,13 @@ using @code{debug-set!}.
@deffn {Scheme Procedure} debug-enable option-name
@deffnx {Scheme Procedure} debug-disable option-name
-@deffnx {Scheme Procedure} debug-set! option-name value
+@deffnx {Scheme Syntax} debug-set! option-name value
Modify the debug options. @code{debug-enable} should be used with boolean
options and switches them on, @code{debug-disable} switches them off.
-@code{debug-set!} can be used to set an option to a specific value.
+
+@code{debug-set!} can be used to set an option to a specific value. Due
+to historical oddities, it is a macro that expects an unquoted option
+name.
@end deffn
@subsubheading Stack overflow
diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi
index 9430c744d..e87331086 100644
--- a/doc/ref/api-evaluation.texi
+++ b/doc/ref/api-evaluation.texi
@@ -341,10 +341,13 @@ using @code{read-set!}.
@deffn {Scheme Procedure} read-enable option-name
@deffnx {Scheme Procedure} read-disable option-name
-@deffnx {Scheme Procedure} read-set! option-name value
+@deffnx {Scheme Syntax} read-set! option-name value
Modify the read options. @code{read-enable} should be used with boolean
options and switches them on, @code{read-disable} switches them off.
-@code{read-set!} can be used to set an option to a specific value.
+
+@code{read-set!} can be used to set an option to a specific value. Due
+to historical oddities, it is a macro that expects an unquoted option
+name.
@end deffn
For example, to make @code{read} fold all symbols to their lower case
@@ -416,10 +419,11 @@ quote-keywordish-symbols reader How to print symbols that have a colon
not '#f'.
@end smalllisp
-These options may be modified with the print-set! procedure.
+These options may be modified with the print-set! syntax.
-@deffn {Scheme Procedure} print-set! option-name value
-Modify the print options.
+@deffn {Scheme Syntax} print-set! option-name value
+Modify the print options. Due to historical oddities, @code{print-set!}
+is a macro that expects an unquoted option name.
@end deffn
diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi
index 09fdc8331..19c066530 100644
--- a/doc/ref/api-io.texi
+++ b/doc/ref/api-io.texi
@@ -336,14 +336,6 @@ If @var{pstate} isn't supplied and @var{port} already has
a print state, the old print state is reused.
@end deffn
-@deffn {Scheme Procedure} print-options-interface [setting]
-@deffnx {C Function} scm_print_options (setting)
-Option interface for the print options. Instead of using
-this procedure directly, use the procedures
-@code{print-enable}, @code{print-disable}, @code{print-set!}
-and @code{print-options}.
-@end deffn
-
@deffn {Scheme Procedure} simple-format destination message . args
@deffnx {C Function} scm_simple_format (destination, message, args)
Write @var{message} to @var{destination}, defaulting to
diff --git a/doc/ref/repl-modules.texi b/doc/ref/repl-modules.texi
index 78c7eee1e..700867272 100644
--- a/doc/ref/repl-modules.texi
+++ b/doc/ref/repl-modules.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2010
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2010, 2011
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -84,18 +84,21 @@ $endif
@node Readline Options
@subsection Readline Options
-@c FIXME::martin: Review me!
-
@cindex readline options
-The readline interface module can be configured in several ways to
-better suit the user's needs. Configuration is done via the readline
-module's options interface, in a similar way to the evaluator and
-debugging options (@pxref{Runtime Options}).
-
-@findex readline-options
-@findex readline-enable
-@findex readline-disable
-@findex readline-set!
+The readline interface module can be tweaked in a few ways to better
+suit the user's needs. Configuration is done via the readline module's
+options interface, in a similar way to the evaluator and debugging
+options (@pxref{Runtime Options}).
+
+@deffn {Scheme Procedure} readline-options
+@deffnx {Scheme Procedure} readline-enable option-name
+@deffnx {Scheme Procedure} readline-disable option-name
+@deffnx {Scheme Syntax} readline-set! option-name value
+Accessors for the readline options. Note that unlike the enable/disable
+procedures, @code{readline-set!} is syntax, which expects an unquoted
+option name.
+@end deffn
+
Here is the list of readline options generated by typing
@code{(readline-options 'help)} in Guile. You can also see the
default values.
@@ -107,15 +110,6 @@ bounce-parens 500 Time (ms) to show matching opening parenthesis
(0 = off).
@end smalllisp
-The history length specifies how many input lines will be remembered.
-If the history contains that many lines and additional lines are
-entered, the oldest lines will be lost. You can switch on/off the
-usage of the history file using the following call.
-
-@lisp
-(readline-disable 'history)
-@end lisp
-
The readline options interface can only be used @emph{after} loading
the readline module, because it is defined in that module.
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 263d6b04c..6f2f79367 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -52,12 +52,17 @@ noinst_PROGRAMS = guile_filter_doc_snarfage gen-scmconfig
gen_scmconfig_SOURCES = gen-scmconfig.c
-## Override default rule; this should be compiled for BUILD host.
-## For some reason, OBJEXT does not include the dot
+## Override default rule; this should be compiled for BUILD host. Note
+## that we don't add $(AM_CPPFLAGS) here, as we need to run this
+## program, but $(top_srcdir)/lib has a gnulib configured for the
+## target. Instead we manually add $(top_builddir), in order to pick up
+## the generated config.h and gen-scmconfig.h. Nothing else from Guile
+## is included by this code generator.
gen-scmconfig.$(OBJEXT): gen-scmconfig.c
$(AM_V_GEN) \
if [ "$(cross_compiling)" = "yes" ]; then \
- $(CC_FOR_BUILD) $(DEFS) $(DEFAULT_INCLUDES) $(AM_CPPFLAGS) -c -o $@ $<; \
+ $(CC_FOR_BUILD) $(DEFS) $(DEFAULT_INCLUDES) -I$(top_builddir) \
+ -c -o $@ $<; \
else \
$(COMPILE) -c -o $@ $<; \
fi
diff --git a/libguile/filesys.c b/libguile/filesys.c
index b43536f0a..2429e80a6 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -473,7 +473,7 @@ static int fstat_Win32 (int fdes, struct stat *buf)
/* Is this a socket ? */
if (getsockopt (fdes, SOL_SOCKET, SO_ERROR, (void *) &error, &optlen) >= 0)
{
- buf->st_mode = _S_IFSOCK | _S_IREAD | _S_IWRITE | _S_IEXEC;
+ buf->st_mode = _S_IREAD | _S_IWRITE | _S_IEXEC;
buf->st_nlink = 1;
buf->st_atime = buf->st_ctime = buf->st_mtime = time (NULL);
return 0;
diff --git a/libguile/goops.c b/libguile/goops.c
index 925f094b6..8ed37fac5 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -170,6 +170,7 @@ static SCM class_bytevector;
static SCM class_uvec;
static SCM vtable_class_map = SCM_BOOL_F;
+static scm_i_pthread_mutex_t vtable_class_map_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
/* Port classes. Allocate 3 times the maximum number of port types so that
input ports, output ports, and in/out ports can be stored at different
@@ -197,6 +198,8 @@ scm_i_define_class_for_vtable (SCM vtable)
{
SCM class;
+ scm_i_pthread_mutex_lock (&vtable_class_map_lock);
+
if (scm_is_false (vtable_class_map))
vtable_class_map = scm_make_weak_key_hash_table (SCM_UNDEFINED);
@@ -205,6 +208,8 @@ scm_i_define_class_for_vtable (SCM vtable)
class = scm_hashq_ref (vtable_class_map, vtable, SCM_BOOL_F);
+ scm_i_pthread_mutex_unlock (&vtable_class_map_lock);
+
if (scm_is_false (class))
{
if (SCM_UNPACK (scm_class_class))
@@ -219,8 +224,12 @@ scm_i_define_class_for_vtable (SCM vtable)
else
/* `create_struct_classes' will fill this in later. */
class = SCM_BOOL_F;
-
+
+ /* Don't worry about races. This only happens when creating a
+ vtable, which happens by definition in one thread. */
+ scm_i_pthread_mutex_lock (&vtable_class_map_lock);
scm_hashq_set_x (vtable_class_map, vtable, class);
+ scm_i_pthread_mutex_unlock (&vtable_class_map_lock);
}
return class;
@@ -2671,6 +2680,7 @@ make_struct_class (void *closure SCM_UNUSED,
static void
create_struct_classes (void)
{
+ /* FIXME: take the vtable_class_map while initializing goops? */
scm_internal_hash_fold (make_struct_class, 0, SCM_BOOL_F,
vtable_class_map);
}
diff --git a/libguile/procprop.c b/libguile/procprop.c
index 39f573700..ac2fa12a8 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -156,9 +156,15 @@ SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
SCM_VALIDATE_PROC (1, proc);
- props = scm_procedure_properties (proc);
-
scm_i_pthread_mutex_lock (&overrides_lock);
+ props = scm_hashq_ref (overrides, proc, SCM_BOOL_F);
+ if (scm_is_false (props))
+ {
+ if (SCM_PROGRAM_P (proc))
+ props = scm_i_program_properties (proc);
+ else
+ props = SCM_EOL;
+ }
scm_hashq_set_x (overrides, proc, scm_assq_set_x (props, key, val));
scm_i_pthread_mutex_unlock (&overrides_lock);
diff --git a/libguile/read.c b/libguile/read.c
index 098854bb4..6e7804dd8 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -357,24 +357,20 @@ flush_ws (SCM port, const char *eoferr)
static SCM scm_read_expression (SCM port);
static SCM scm_read_sharp (int chr, SCM port);
-static SCM recsexpr (SCM obj, long line, int column, SCM filename);
static SCM
scm_read_sexp (scm_t_wchar chr, SCM port)
#define FUNC_NAME "scm_i_lreadparen"
{
- register int c;
- register SCM tmp;
- register SCM tl, ans = SCM_EOL;
- SCM tl2 = SCM_EOL, ans2 = SCM_EOL, copy = SCM_BOOL_F;
+ int c;
+ SCM tmp, tl, ans = SCM_EOL;
const int terminating_char = ((chr == '[') ? ']' : ')');
/* Need to capture line and column numbers here. */
long line = SCM_LINUM (port);
int column = SCM_COL (port) - 1;
-
c = flush_ws (port, FUNC_NAME);
if (terminating_char == c)
return SCM_EOL;
@@ -393,12 +389,6 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
/* Build the head of the list structure. */
ans = tl = scm_cons (tmp, SCM_EOL);
- if (SCM_COPY_SOURCE_P)
- ans2 = tl2 = scm_cons (scm_is_pair (tmp)
- ? copy
- : tmp,
- SCM_EOL);
-
while (terminating_char != (c = flush_ws (port, FUNC_NAME)))
{
SCM new_tail;
@@ -415,10 +405,6 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
{
SCM_SETCDR (tl, tmp = scm_read_expression (port));
- if (SCM_COPY_SOURCE_P)
- SCM_SETCDR (tl2, scm_cons (scm_is_pair (tmp) ? copy : tmp,
- SCM_EOL));
-
c = flush_ws (port, FUNC_NAME);
if (terminating_char != c)
scm_i_input_error (FUNC_NAME, port,
@@ -429,27 +415,12 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
new_tail = scm_cons (tmp, SCM_EOL);
SCM_SETCDR (tl, new_tail);
tl = new_tail;
-
- if (SCM_COPY_SOURCE_P)
- {
- SCM new_tail2 = scm_cons (scm_is_pair (tmp)
- ? copy
- : tmp, SCM_EOL);
- SCM_SETCDR (tl2, new_tail2);
- tl2 = new_tail2;
- }
}
exit:
if (SCM_RECORD_POSITIONS_P)
- scm_hashq_set_x (scm_source_whash,
- ans,
- scm_make_srcprops (line, column,
- SCM_FILENAME (port),
- SCM_COPY_SOURCE_P
- ? ans2
- : SCM_UNDEFINED,
- SCM_EOL));
+ scm_i_set_source_properties_x (ans, line, column, SCM_FILENAME (port));
+
return ans;
}
#undef FUNC_NAME
@@ -805,16 +776,7 @@ scm_read_quote (int chr, SCM port)
p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
if (SCM_RECORD_POSITIONS_P)
- scm_hashq_set_x (scm_source_whash, p,
- scm_make_srcprops (line, column,
- SCM_FILENAME (port),
- SCM_COPY_SOURCE_P
- ? (scm_cons2 (SCM_CAR (p),
- SCM_CAR (SCM_CDR (p)),
- SCM_EOL))
- : SCM_UNDEFINED,
- SCM_EOL));
-
+ scm_i_set_source_properties_x (p, line, column, SCM_FILENAME (port));
return p;
}
@@ -864,16 +826,7 @@ scm_read_syntax (int chr, SCM port)
p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
if (SCM_RECORD_POSITIONS_P)
- scm_hashq_set_x (scm_source_whash, p,
- scm_make_srcprops (line, column,
- SCM_FILENAME (port),
- SCM_COPY_SOURCE_P
- ? (scm_cons2 (SCM_CAR (p),
- SCM_CAR (SCM_CDR (p)),
- SCM_EOL))
- : SCM_UNDEFINED,
- SCM_EOL));
-
+ scm_i_set_source_properties_x (p, line, column, SCM_FILENAME (port));
return p;
}
@@ -1332,14 +1285,11 @@ scm_read_sharp_extension (int chr, SCM port)
SCM got;
got = scm_call_2 (proc, SCM_MAKE_CHAR (chr), port);
- if (!scm_is_eq (got, SCM_UNSPECIFIED))
- {
- if (SCM_RECORD_POSITIONS_P)
- return (recsexpr (got, line, column,
- SCM_FILENAME (port)));
- else
- return got;
- }
+
+ if (scm_is_pair (got) && !scm_i_has_source_properties (got))
+ scm_i_set_source_properties_x (got, line, column, SCM_FILENAME (port));
+
+ return got;
}
return SCM_UNSPECIFIED;
@@ -1531,53 +1481,6 @@ SCM_DEFINE (scm_read, "read", 0, 1, 0,
-/* Used when recording expressions constructed by `scm_read_sharp ()'. */
-static SCM
-recsexpr (SCM obj, long line, int column, SCM filename)
-{
- if (!scm_is_pair(obj)) {
- return obj;
- } else {
- SCM tmp, copy;
- /* If this sexpr is visible in the read:sharp source, we want to
- keep that information, so only record non-constant cons cells
- which haven't previously been read by the reader. */
- if (scm_is_false (scm_hashq_ref (scm_source_whash, obj, SCM_BOOL_F)))
- {
- if (SCM_COPY_SOURCE_P)
- {
- copy = scm_cons (recsexpr (SCM_CAR (obj), line, column, filename),
- SCM_UNDEFINED);
- for (tmp = obj; scm_is_pair (tmp); tmp = SCM_CDR (tmp))
- {
- SCM_SETCDR (copy, scm_cons (recsexpr (SCM_CAR (tmp),
- line,
- column,
- filename),
- SCM_UNDEFINED));
- copy = SCM_CDR (copy);
- }
- SCM_SETCDR (copy, tmp);
- }
- else
- {
- recsexpr (SCM_CAR (obj), line, column, filename);
- for (tmp = obj; scm_is_pair (tmp); tmp = SCM_CDR (tmp))
- recsexpr (SCM_CAR (tmp), line, column, filename);
- copy = SCM_UNDEFINED;
- }
- scm_hashq_set_x (scm_source_whash,
- obj,
- scm_make_srcprops (line,
- column,
- filename,
- copy,
- SCM_EOL));
- }
- return obj;
- }
-}
-
/* Manipulate the read-hash-procedures alist. This could be written in
Scheme, but maybe it will also be used by C code during initialisation. */
SCM_DEFINE (scm_read_hash_extend, "read-hash-extend", 2, 0, 0,
diff --git a/libguile/smob.c b/libguile/smob.c
index adb34ba0b..c414913fc 100644
--- a/libguile/smob.c
+++ b/libguile/smob.c
@@ -418,12 +418,16 @@ scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (),
}
static SCM tramp_weak_map = SCM_BOOL_F;
+static scm_i_pthread_mutex_t tramp_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
SCM
scm_i_smob_apply_trampoline (SCM smob)
{
- /* could use hashq-create-handle!, but i don't know what to do if it returns a
- weak pair */
- SCM tramp = scm_hashq_ref (tramp_weak_map, smob, SCM_BOOL_F);
+ SCM tramp;
+
+ scm_i_pthread_mutex_lock (&tramp_lock);
+ tramp = scm_hashq_ref (tramp_weak_map, smob, SCM_BOOL_F);
+ scm_i_pthread_mutex_unlock (&tramp_lock);
if (scm_is_true (tramp))
return tramp;
@@ -440,7 +444,12 @@ scm_i_smob_apply_trampoline (SCM smob)
SCM_SIMPLE_VECTOR_SET (objtable, 1, scm_from_locale_symbol (name));
tramp = scm_make_program (SCM_SMOB_DESCRIPTOR (smob).apply_trampoline_objcode,
objtable, SCM_BOOL_F);
+
+ /* Race conditions (between the ref and this set!) cannot cause
+ any harm here. */
+ scm_i_pthread_mutex_lock (&tramp_lock);
scm_hashq_set_x (tramp_weak_map, smob, tramp);
+ scm_i_pthread_mutex_unlock (&tramp_lock);
return tramp;
}
}
diff --git a/libguile/srcprop.c b/libguile/srcprop.c
index 4eb1ccaac..dc333d46c 100644
--- a/libguile/srcprop.c
+++ b/libguile/srcprop.c
@@ -38,6 +38,8 @@
#include "libguile/validate.h"
#include "libguile/srcprop.h"
+#include "libguile/private-options.h"
+
/* {Source Properties}
*
@@ -57,8 +59,9 @@ SCM_GLOBAL_SYMBOL (scm_sym_filename, "filename");
SCM_GLOBAL_SYMBOL (scm_sym_copy, "copy");
SCM_GLOBAL_SYMBOL (scm_sym_line, "line");
SCM_GLOBAL_SYMBOL (scm_sym_column, "column");
-SCM scm_source_whash;
+static SCM scm_source_whash;
+static scm_i_pthread_mutex_t source_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
/*
@@ -163,7 +166,11 @@ SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0,
{
SCM p;
SCM_VALIDATE_NIM (1, obj);
- p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
+
+ scm_i_pthread_mutex_lock (&source_lock);
+ p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
+ scm_i_pthread_mutex_unlock (&source_lock);
+
if (SRCPROPSP (p))
return scm_srcprops_to_alist (p);
else
@@ -181,11 +188,49 @@ SCM_DEFINE (scm_set_source_properties_x, "set-source-properties!", 2, 0, 0,
#define FUNC_NAME s_scm_set_source_properties_x
{
SCM_VALIDATE_NIM (1, obj);
+
+ scm_i_pthread_mutex_lock (&source_lock);
scm_hashq_set_x (scm_source_whash, obj, alist);
+ scm_i_pthread_mutex_unlock (&source_lock);
+
return alist;
}
#undef FUNC_NAME
+int
+scm_i_has_source_properties (SCM obj)
+#define FUNC_NAME "%set-source-properties"
+{
+ int ret;
+
+ SCM_VALIDATE_NIM (1, obj);
+
+ scm_i_pthread_mutex_lock (&source_lock);
+ ret = scm_is_true (scm_hashq_ref (scm_source_whash, obj, SCM_BOOL_F));
+ scm_i_pthread_mutex_unlock (&source_lock);
+
+ return ret;
+}
+#undef FUNC_NAME
+
+
+void
+scm_i_set_source_properties_x (SCM obj, long line, int col, SCM fname)
+#define FUNC_NAME "%set-source-properties"
+{
+ SCM_VALIDATE_NIM (1, obj);
+
+ scm_i_pthread_mutex_lock (&source_lock);
+ scm_hashq_set_x (scm_source_whash, obj,
+ scm_make_srcprops (line, col, fname,
+ SCM_COPY_SOURCE_P
+ ? scm_copy_tree (obj)
+ : SCM_UNDEFINED,
+ SCM_EOL));
+ scm_i_pthread_mutex_unlock (&source_lock);
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0,
(SCM obj, SCM key),
"Return the source property specified by @var{key} from\n"
@@ -194,7 +239,11 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0,
{
SCM p;
SCM_VALIDATE_NIM (1, obj);
+
+ scm_i_pthread_mutex_lock (&source_lock);
p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
+ scm_i_pthread_mutex_unlock (&source_lock);
+
if (!SRCPROPSP (p))
goto alist;
if (scm_is_eq (scm_sym_line, key))
@@ -222,6 +271,8 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0,
{
SCM p;
SCM_VALIDATE_NIM (1, obj);
+
+ scm_i_pthread_mutex_lock (&source_lock);
p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
if (scm_is_eq (scm_sym_line, key))
@@ -258,6 +309,8 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0,
scm_hashq_set_x (scm_source_whash, obj,
scm_acons (key, datum, p));
}
+ scm_i_pthread_mutex_unlock (&source_lock);
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -272,10 +325,12 @@ SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0,
{
SCM p, z;
z = scm_cons (x, y);
+ scm_i_pthread_mutex_lock (&source_lock);
/* Copy source properties possibly associated with xorig. */
p = scm_hashq_ref (scm_source_whash, xorig, SCM_BOOL_F);
if (scm_is_true (p))
scm_hashq_set_x (scm_source_whash, z, p);
+ scm_i_pthread_mutex_unlock (&source_lock);
return z;
}
#undef FUNC_NAME
diff --git a/libguile/srcprop.h b/libguile/srcprop.h
index 5c9ccb960..250756dcc 100644
--- a/libguile/srcprop.h
+++ b/libguile/srcprop.h
@@ -33,7 +33,6 @@
#define SCM_SOURCE_PROPERTY_FLAG_BREAK 1
SCM_API scm_t_bits scm_tc16_srcprops;
-SCM_INTERNAL SCM scm_source_whash;
SCM_API SCM scm_sym_filename;
SCM_API SCM scm_sym_copy;
@@ -47,6 +46,9 @@ SCM_API SCM scm_source_property (SCM obj, SCM key);
SCM_API SCM scm_set_source_property_x (SCM obj, SCM key, SCM datum);
SCM_API SCM scm_source_properties (SCM obj);
SCM_API SCM scm_set_source_properties_x (SCM obj, SCM props);
+SCM_INTERNAL int scm_i_has_source_properties (SCM obj);
+SCM_INTERNAL void scm_i_set_source_properties_x (SCM obj, long line, int col,
+ SCM fname);
SCM_API SCM scm_cons_source (SCM xorig, SCM x, SCM y);
SCM_INTERNAL void scm_init_srcprop (void);
diff --git a/libguile/stime.c b/libguile/stime.c
index 1c4f407f9..dda82e720 100644
--- a/libguile/stime.c
+++ b/libguile/stime.c
@@ -142,7 +142,11 @@ get_internal_real_time_posix_timer (void)
ts.tv_nsec - posix_real_time_base.tv_nsec);
}
-#ifdef _POSIX_CPUTIME
+#if defined _POSIX_CPUTIME && defined CLOCK_PROCESS_CPUTIME_ID
+/* You see, FreeBSD defines _POSIX_CPUTIME but not
+ CLOCK_PROCESS_CPUTIME_ID. */
+#define HAVE_POSIX_CPUTIME 1
+
struct timespec posix_run_time_base;
static long
@@ -847,7 +851,7 @@ scm_init_stime()
if (clock_gettime (CLOCK_REALTIME, &posix_real_time_base) == 0)
get_internal_real_time = get_internal_real_time_posix_timer;
-#ifdef _POSIX_CPUTIME
+#ifdef HAVE_POSIX_CPUTIME
{
clockid_t dummy;
@@ -859,7 +863,7 @@ scm_init_stime()
else
errno = 0;
}
-#endif /* _POSIX_CPUTIME */
+#endif /* HAVE_POSIX_CPUTIME */
#endif /* HAVE_CLOCKTIME */
/* If needed, init and use gettimeofday timer. */
diff --git a/libguile/symbols.c b/libguile/symbols.c
index 2a1b46dce..59aca002e 100644
--- a/libguile/symbols.c
+++ b/libguile/symbols.c
@@ -52,6 +52,7 @@
static SCM symbols;
+static scm_i_pthread_mutex_t symbols_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
#ifdef GUILE_DEBUG
SCM_DEFINE (scm_sys_symbols, "%symbols", 0, 0, 0,
@@ -108,13 +109,11 @@ lookup_interned_symbol (SCM name, unsigned long raw_hash)
data.string = name;
data.string_hash = raw_hash;
- /* Strictly speaking, we should take a lock here. But instead we rely
- on the fact that if this fails, we do take the lock on the
- intern_symbol path; and since nothing deletes from the hash table
- except GC, we should be OK. */
+ scm_i_pthread_mutex_lock (&symbols_lock);
handle = scm_hash_fn_get_handle_by_hash (symbols, raw_hash,
string_lookup_predicate_fn,
&data);
+ scm_i_pthread_mutex_unlock (&symbols_lock);
if (scm_is_true (handle))
return SCM_CAR (handle);
@@ -151,13 +150,11 @@ lookup_interned_latin1_symbol (const char *str, size_t len,
data.len = len;
data.string_hash = raw_hash;
- /* Strictly speaking, we should take a lock here. But instead we rely
- on the fact that if this fails, we do take the lock on the
- intern_symbol path; and since nothing deletes from the hash table
- except GC, we should be OK. */
+ scm_i_pthread_mutex_lock (&symbols_lock);
handle = scm_hash_fn_get_handle_by_hash (symbols, raw_hash,
latin1_lookup_predicate_fn,
&data);
+ scm_i_pthread_mutex_unlock (&symbols_lock);
if (scm_is_true (handle))
return SCM_CAR (handle);
@@ -187,8 +184,6 @@ symbol_lookup_assoc_fn (SCM obj, SCM alist, void *closure)
return SCM_BOOL_F;
}
-static scm_i_pthread_mutex_t intern_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-
/* Intern SYMBOL, an uninterned symbol. Might return a different
symbol, if another one was interned at the same time. */
static SCM
@@ -196,12 +191,12 @@ intern_symbol (SCM symbol)
{
SCM handle;
- scm_i_pthread_mutex_lock (&intern_lock);
+ scm_i_pthread_mutex_lock (&symbols_lock);
handle = scm_hash_fn_create_handle_x (symbols, symbol, SCM_UNDEFINED,
symbol_lookup_hash_fn,
symbol_lookup_assoc_fn,
NULL);
- scm_i_pthread_mutex_unlock (&intern_lock);
+ scm_i_pthread_mutex_unlock (&symbols_lock);
return SCM_CAR (handle);
}
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 6dab79eea..0493de514 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -3043,15 +3043,15 @@ module '(ice-9 q) '(make-q q-length))}."
#`(#:filename 'f . #,(parse #'args imp exp rex rep aut)))
((#:use-module (name name* ...) . args)
(and (and-map symbol? (syntax->datum #'(name name* ...))))
- (parse #'args (cons #'((name name* ...)) imp) exp rex rep aut))
+ (parse #'args #`(#,@imp ((name name* ...))) exp rex rep aut))
((#:use-syntax (name name* ...) . args)
(and (and-map symbol? (syntax->datum #'(name name* ...))))
#`(#:transformer '(name name* ...)
- . #,(parse #'args (cons #'((name name* ...)) imp) exp rex rep aut)))
+ . #,(parse #'args #`(#,@imp ((name name* ...))) exp rex rep aut)))
((#:use-module ((name name* ...) arg ...) . args)
(and (and-map symbol? (syntax->datum #'(name name* ...))))
(parse #'args
- (cons #`((name name* ...) #,@(parse-iface #'(arg ...))) imp)
+ #`(#,@imp ((name name* ...) #,@(parse-iface #'(arg ...))))
exp rex rep aut))
((#:export (ex ...) . args)
(parse #'args imp #`(#,@exp ex ...) rex rep aut))
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 2801aa25b..1f9fd5074 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -1,6 +1,6 @@
;;; installed-scm-file
-;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -245,31 +245,28 @@
(lambda (x)
(syntax-case x ()
((_ (k arg rest ...) out ...)
- (keyword? (syntax->datum (syntax k)))
- (case (syntax->datum (syntax k))
+ (keyword? (syntax->datum #'k))
+ (case (syntax->datum #'k)
((#:getter #:setter)
- (syntax
- (define-class-pre-definition (rest ...)
- out ...
- (if (or (not (defined? 'arg))
- (not (is-a? arg <generic>)))
- (toplevel-define!
- 'arg
- (ensure-generic (if (defined? 'arg) arg #f) 'arg))))))
+ #'(define-class-pre-definition (rest ...)
+ out ...
+ (if (or (not (defined? 'arg))
+ (not (is-a? arg <generic>)))
+ (toplevel-define!
+ 'arg
+ (ensure-generic (if (defined? 'arg) arg #f) 'arg)))))
((#:accessor)
- (syntax
- (define-class-pre-definition (rest ...)
- out ...
- (if (or (not (defined? 'arg))
- (not (is-a? arg <accessor>)))
- (toplevel-define!
- 'arg
- (ensure-accessor (if (defined? 'arg) arg #f) 'arg))))))
+ #'(define-class-pre-definition (rest ...)
+ out ...
+ (if (or (not (defined? 'arg))
+ (not (is-a? arg <accessor>)))
+ (toplevel-define!
+ 'arg
+ (ensure-accessor (if (defined? 'arg) arg #f) 'arg)))))
(else
- (syntax
- (define-class-pre-definition (rest ...) out ...)))))
+ #'(define-class-pre-definition (rest ...) out ...))))
((_ () out ...)
- (syntax (begin out ...))))))
+ #'(begin out ...)))))
;; Some slot options require extra definitions to be made. In
;; particular, we want to make sure that the generic function objects
@@ -279,17 +276,17 @@
(lambda (x)
(syntax-case x ()
((_ () out ...)
- (syntax (begin out ...)))
+ #'(begin out ...))
((_ (slot rest ...) out ...)
- (keyword? (syntax->datum (syntax slot)))
- (syntax (begin out ...)))
+ (keyword? (syntax->datum #'slot))
+ #'(begin out ...))
((_ (slot rest ...) out ...)
- (identifier? (syntax slot))
- (syntax (define-class-pre-definitions (rest ...)
- out ...)))
+ (identifier? #'slot)
+ #'(define-class-pre-definitions (rest ...)
+ out ...))
((_ ((slotname slotopt ...) rest ...) out ...)
- (syntax (define-class-pre-definitions (rest ...)
- out ... (define-class-pre-definition (slotopt ...))))))))
+ #'(define-class-pre-definitions (rest ...)
+ out ... (define-class-pre-definition (slotopt ...)))))))
(define-syntax define-class
(syntax-rules ()
@@ -491,46 +488,46 @@
(let lp ((ls args) (formals '()) (specializers '()))
(syntax-case ls ()
(((f s) . rest)
- (and (identifier? (syntax f)) (identifier? (syntax s)))
- (lp (syntax rest)
- (cons (syntax f) formals)
- (cons (syntax s) specializers)))
+ (and (identifier? #'f) (identifier? #'s))
+ (lp #'rest
+ (cons #'f formals)
+ (cons #'s specializers)))
((f . rest)
- (identifier? (syntax f))
- (lp (syntax rest)
- (cons (syntax f) formals)
- (cons (syntax <top>) specializers)))
+ (identifier? #'f)
+ (lp #'rest
+ (cons #'f formals)
+ (cons #'<top> specializers)))
(()
(list (reverse formals)
- (reverse (cons (syntax '()) specializers))))
+ (reverse (cons #''() specializers))))
(tail
- (identifier? (syntax tail))
- (list (append (reverse formals) (syntax tail))
- (reverse (cons (syntax <top>) specializers)))))))
+ (identifier? #'tail)
+ (list (append (reverse formals) #'tail)
+ (reverse (cons #'<top> specializers)))))))
(define (find-free-id exp referent)
(syntax-case exp ()
((x . y)
- (or (find-free-id (syntax x) referent)
- (find-free-id (syntax y) referent)))
+ (or (find-free-id #'x referent)
+ (find-free-id #'y referent)))
(x
- (identifier? (syntax x))
- (let ((id (datum->syntax (syntax x) referent)))
- (and (free-identifier=? (syntax x) id) id)))
+ (identifier? #'x)
+ (let ((id (datum->syntax #'x referent)))
+ (and (free-identifier=? #'x id) id)))
(_ #f)))
(define (compute-procedure formals body)
(syntax-case body ()
((body0 ...)
(with-syntax ((formals formals))
- (syntax (lambda formals body0 ...))))))
+ #'(lambda formals body0 ...)))))
(define (->proper args)
(let lp ((ls args) (out '()))
(syntax-case ls ()
- ((x . xs) (lp (syntax xs) (cons (syntax x) out)))
+ ((x . xs) (lp #'xs (cons #'x out)))
(() (reverse out))
- (tail (reverse (cons (syntax tail) out))))))
+ (tail (reverse (cons #'tail out))))))
(define (compute-make-procedure formals body next-method)
(syntax-case body ()
@@ -538,24 +535,22 @@
(with-syntax ((next-method next-method))
(syntax-case formals ()
((formal ...)
- (syntax
- (lambda (real-next-method)
- (lambda (formal ...)
- (let ((next-method (lambda args
- (if (null? args)
- (real-next-method formal ...)
- (apply real-next-method args)))))
- body ...)))))
+ #'(lambda (real-next-method)
+ (lambda (formal ...)
+ (let ((next-method (lambda args
+ (if (null? args)
+ (real-next-method formal ...)
+ (apply real-next-method args)))))
+ body ...))))
(formals
- (with-syntax (((formal ...) (->proper (syntax formals))))
- (syntax
- (lambda (real-next-method)
- (lambda formals
- (let ((next-method (lambda args
- (if (null? args)
- (apply real-next-method formal ...)
- (apply real-next-method args)))))
- body ...)))))))))))
+ (with-syntax (((formal ...) (->proper #'formals)))
+ #'(lambda (real-next-method)
+ (lambda formals
+ (let ((next-method (lambda args
+ (if (null? args)
+ (apply real-next-method formal ...)
+ (apply real-next-method args)))))
+ body ...))))))))))
(define (compute-procedures formals body)
;; So, our use of this is broken, because it operates on the
@@ -564,28 +559,27 @@
(let ((id (find-free-id body 'next-method)))
(if id
;; return a make-procedure
- (values (syntax #f)
+ (values #'#f
(compute-make-procedure formals body id))
(values (compute-procedure formals body)
- (syntax #f)))))
+ #'#f))))
(syntax-case x ()
- ((_ args) (syntax (method args (if #f #f))))
+ ((_ args) #'(method args (if #f #f)))
((_ args body0 body1 ...)
- (with-syntax (((formals (specializer ...)) (parse-args (syntax args))))
+ (with-syntax (((formals (specializer ...)) (parse-args #'args)))
(call-with-values
(lambda ()
- (compute-procedures (syntax formals) (syntax (body0 body1 ...))))
+ (compute-procedures #'formals #'(body0 body1 ...)))
(lambda (procedure make-procedure)
(with-syntax ((procedure procedure)
(make-procedure make-procedure))
- (syntax
- (make <method>
- #:specializers (cons* specializer ...)
- #:formals 'formals
- #:body '(body0 body1 ...)
- #:make-procedure make-procedure
- #:procedure procedure))))))))))
+ #'(make <method>
+ #:specializers (cons* specializer ...)
+ #:formals 'formals
+ #:body '(body0 body1 ...)
+ #:make-procedure make-procedure
+ #:procedure procedure)))))))))
;;;
;;; {add-method!}
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
index 3dbaa039b..4ae01be68 100644
--- a/module/rnrs/io/ports.scm
+++ b/module/rnrs/io/ports.scm
@@ -170,22 +170,44 @@
;;;
(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)))))))
+ (with-throw-handler '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)))))))
+
+(define (with-i/o-port-error port make-primary-condition thunk)
+ (with-throw-handler 'system-error
+ thunk
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (if (memv errno (list EIO EFBIG ENOSPC EPIPE))
+ (raise (condition (make-primary-condition)
+ (make-i/o-port-error port)))
+ (apply throw args))))))
+
+(define-syntax with-textual-output-conditions
+ (syntax-rules ()
+ ((_ port body0 body ...)
+ (with-i/o-port-error port make-i/o-write-error
+ (lambda () (with-i/o-encoding-error body0 body ...))))))
+
+(define-syntax with-textual-input-conditions
+ (syntax-rules ()
+ ((_ port body0 body ...)
+ (with-i/o-port-error port make-i/o-read-error
+ (lambda () (with-i/o-decoding-error body0 body ...))))))
;;;
@@ -313,7 +335,10 @@ as a string, and a thunk to retrieve the characters associated with that port."
O_CREAT)
(if (enum-set-member? 'no-truncate file-options)
0
- O_TRUNC)))
+ O_TRUNC)
+ (if (enum-set-member? 'no-fail file-options)
+ 0
+ O_EXCL)))
(port (with-i/o-filename-conditions filename
(lambda () (open filename flags)))))
(cond (maybe-transcoder
@@ -363,13 +388,13 @@ return the characters accumulated in that port."
(raise (make-i/o-encoding-error port chr)))))))
(define (put-char port char)
- (with-i/o-encoding-error (write-char char port)))
+ (with-textual-output-conditions port (write-char char port)))
(define (put-datum port datum)
- (with-i/o-encoding-error (write datum port)))
+ (with-textual-output-conditions port (write datum port)))
(define* (put-string port s #:optional start count)
- (with-i/o-encoding-error
+ (with-textual-output-conditions port
(cond ((not (string? s))
(assertion-violation 'put-string "expected string" s))
((and start count)
@@ -382,8 +407,7 @@ return the characters accumulated in that port."
;; Defined here to be able to make use of `with-i/o-encoding-error', but
;; not exported from here, but from `(rnrs io simple)'.
(define* (display object #:optional (port (current-output-port)))
- (with-i/o-encoding-error
- (guile:display object port)))
+ (with-textual-output-conditions port (guile:display object port)))
;;;
@@ -406,16 +430,16 @@ return the characters accumulated in that port."
(raise (make-i/o-decoding-error port)))))))
(define (get-char port)
- (with-i/o-decoding-error (read-char port)))
+ (with-textual-input-conditions port (read-char port)))
(define (get-datum port)
- (with-i/o-decoding-error (read port)))
+ (with-textual-input-conditions port (read port)))
(define (get-line port)
- (with-i/o-decoding-error (read-line port 'trim)))
+ (with-textual-input-conditions port (read-line port 'trim)))
(define (get-string-all port)
- (with-i/o-decoding-error (read-delimited "" port 'concat)))
+ (with-textual-input-conditions port (read-delimited "" port 'concat)))
(define (get-string-n port count)
"Read up to @var{count} characters from @var{port}.
@@ -429,7 +453,7 @@ the characters read."
(else (substring/shared s 0 rv)))))
(define (lookahead-char port)
- (with-i/o-decoding-error (peek-char port)))
+ (with-textual-input-conditions port (peek-char port)))
;;;
diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am
index cf1fc4fe3..00655bd12 100644
--- a/test-suite/standalone/Makefile.am
+++ b/test-suite/standalone/Makefile.am
@@ -31,6 +31,7 @@ BUILT_SOURCES =
EXTRA_DIST =
TESTS_ENVIRONMENT = \
+ srcdir="$(srcdir)" \
builddir="$(builddir)" \
GUILE_AUTO_COMPILE=0 "${top_builddir}/meta/uninstalled-env"
@@ -75,6 +76,11 @@ TESTS += test-require-extension
check_SCRIPTS += test-guile-snarf
TESTS += test-guile-snarf
+check_SCRIPTS += test-import-order
+TESTS += test-import-order
+EXTRA_DIST += test-import-order-a.scm test-import-order-b.scm \
+ test-import-order-c.scm test-import-order-d.scm
+
# test-num2integral
test_num2integral_SOURCES = test-num2integral.c
test_num2integral_CFLAGS = ${test_cflags}
diff --git a/test-suite/standalone/test-import-order b/test-suite/standalone/test-import-order
new file mode 100755
index 000000000..8b51312a9
--- /dev/null
+++ b/test-suite/standalone/test-import-order
@@ -0,0 +1,31 @@
+#!/bin/sh
+exec guile -q -L "$srcdir" -s "$0" "$@"
+!#
+
+(define-module (base)
+ #:export (push! order))
+
+(define order '())
+(define (push!)
+ (set! order `(,@order ,(module-name (current-module)))))
+
+(define-module (test-1)
+ #:use-module (base)
+ #:use-module (test-import-order-a)
+ #:use-module (test-import-order-b))
+
+(use-modules (test-import-order-c) (test-import-order-d))
+
+(if (not (equal? order
+ '((test-import-order-a)
+ (test-import-order-b)
+ (test-import-order-c)
+ (test-import-order-d))))
+ (begin
+ (format (current-error-port) "Unexpected import order: ~a" order)
+ (exit 1))
+ (exit 0))
+
+;; Local Variables:
+;; mode: scheme
+;; End: \ No newline at end of file
diff --git a/test-suite/standalone/test-import-order-a.scm b/test-suite/standalone/test-import-order-a.scm
new file mode 100644
index 000000000..d6fa29def
--- /dev/null
+++ b/test-suite/standalone/test-import-order-a.scm
@@ -0,0 +1,4 @@
+(define-module (test-import-order-a)
+ #:use-module (base))
+
+(push!)
diff --git a/test-suite/standalone/test-import-order-b.scm b/test-suite/standalone/test-import-order-b.scm
new file mode 100644
index 000000000..bc41bdf9f
--- /dev/null
+++ b/test-suite/standalone/test-import-order-b.scm
@@ -0,0 +1,4 @@
+(define-module (test-import-order-b)
+ #:use-module (base))
+
+(push!)
diff --git a/test-suite/standalone/test-import-order-c.scm b/test-suite/standalone/test-import-order-c.scm
new file mode 100644
index 000000000..4b58c3d75
--- /dev/null
+++ b/test-suite/standalone/test-import-order-c.scm
@@ -0,0 +1,4 @@
+(define-module (test-import-order-c)
+ #:use-module (base))
+
+(push!)
diff --git a/test-suite/standalone/test-import-order-d.scm b/test-suite/standalone/test-import-order-d.scm
new file mode 100644
index 000000000..fb071be93
--- /dev/null
+++ b/test-suite/standalone/test-import-order-d.scm
@@ -0,0 +1,4 @@
+(define-module (test-import-order-d)
+ #:use-module (base))
+
+(push!)
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index 06431bb76..7a382b75b 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -19,9 +19,11 @@
(define-module (test-io-ports)
#:use-module (test-suite lib)
+ #:use-module (test-suite guile-test)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (rnrs io ports)
+ #:use-module (rnrs io simple)
#:use-module (rnrs exceptions)
#:use-module (rnrs bytevectors))
@@ -31,6 +33,45 @@
;; Set the default encoding of future ports to be Latin-1.
(fluid-set! %default-port-encoding #f)
+(define-syntax pass-if-condition
+ (syntax-rules ()
+ ((_ name predicate body0 body ...)
+ (let ((cookie (list 'cookie)))
+ (pass-if name
+ (eq? cookie (guard (c ((predicate c) cookie))
+ body0 body ...)))))))
+
+(define (test-file)
+ (data-file-name "ports-test.tmp"))
+
+;; A input/output port that swallows all output, and produces just
+;; spaces on input. Reading and writing beyond `failure-position'
+;; produces `system-error' exceptions. Used for testing exception
+;; behavior.
+(define* (make-failing-port #:optional (failure-position 0))
+ (define (maybe-fail index errno)
+ (if (> index failure-position)
+ (scm-error 'system-error
+ 'failing-port
+ "I/O beyond failure position" '()
+ (list errno))))
+ (let ((read-index 0)
+ (write-index 0))
+ (define (write-char chr)
+ (set! write-index (+ 1 write-index))
+ (maybe-fail write-index ENOSPC))
+ (make-soft-port
+ (vector write-char
+ (lambda (str) ;; write-string
+ (for-each write-char (string->list str)))
+ (lambda () #t) ;; flush-output
+ (lambda () ;; read-char
+ (set! read-index (+ read-index 1))
+ (maybe-fail read-index EIO)
+ #\space)
+ (lambda () #t)) ;; close-port
+ "rw")))
+
(with-test-prefix "7.2.5 End-of-File Object"
@@ -421,6 +462,37 @@
(with-test-prefix "8.2.10 Output ports"
+ (let ((filename (test-file)))
+ (pass-if "open-file-output-port [opens binary port]"
+ (call-with-port (open-file-output-port filename)
+ (lambda (port)
+ (put-bytevector port '#vu8(1 2 3))
+ (binary-port? port))))
+
+ (pass-if-condition "open-file-output-port [exception: already-exists]"
+ i/o-file-already-exists-error?
+ (open-file-output-port filename))
+
+ (pass-if "open-file-output-port [no-fail no-truncate]"
+ (and
+ (call-with-port (open-file-output-port filename
+ (file-options no-fail no-truncate))
+ (lambda (port)
+ (= 0 (port-position port))))
+ (= 3 (stat:size (stat filename)))))
+
+ (pass-if "open-file-output-port [no-fail]"
+ (and
+ (call-with-port (open-file-output-port filename (file-options no-fail))
+ binary-port?)
+ (= 0 (stat:size (stat filename)))))
+
+ (delete-file filename)
+
+ (pass-if-condition "open-file-output-port [exception: does-not-exist]"
+ i/o-file-does-not-exist-error?
+ (open-file-output-port filename (file-options no-create))))
+
(pass-if "open-bytevector-output-port"
(let-values (((port get-content)
(open-bytevector-output-port #f)))
@@ -627,7 +699,69 @@
(let ((port (open-input-string "GNU Guile"))
(s (string-copy "Isn't XXX great?")))
(and (= 3 (get-string-n! port s 6 3))
- (string=? s "Isn't GNU great?")))))
+ (string=? s "Isn't GNU great?"))))
+
+ (with-test-prefix "read error"
+ (pass-if-condition "get-char" i/o-read-error?
+ (get-char (make-failing-port)))
+ (pass-if-condition "lookahead-char" i/o-read-error?
+ (lookahead-char (make-failing-port)))
+ ;; FIXME: these are not yet exception-correct
+ #|
+ (pass-if-condition "get-string-n" i/o-read-error?
+ (get-string-n (make-failing-port) 5))
+ (pass-if-condition "get-string-n!" i/o-read-error?
+ (get-string-n! (make-failing-port) (make-string 5) 0 5))
+ |#
+ (pass-if-condition "get-string-all" i/o-read-error?
+ (get-string-all (make-failing-port 100)))
+ (pass-if-condition "get-line" i/o-read-error?
+ (get-line (make-failing-port)))
+ (pass-if-condition "get-datum" i/o-read-error?
+ (get-datum (make-failing-port)))))
+
+(with-test-prefix "8.2.12 Textual Output"
+
+ (with-test-prefix "write error"
+ (pass-if-condition "put-char" i/o-write-error?
+ (put-char (make-failing-port) #\G))
+ (pass-if-condition "put-string" i/o-write-error?
+ (put-string (make-failing-port) "Hello World!"))
+ (pass-if-condition "put-datum" i/o-write-error?
+ (put-datum (make-failing-port) '(hello world!)))))
+
+(with-test-prefix "8.3 Simple I/O"
+ (with-test-prefix "read error"
+ (pass-if-condition "read-char" i/o-read-error?
+ (read-char (make-failing-port)))
+ (pass-if-condition "peek-char" i/o-read-error?
+ (peek-char (make-failing-port)))
+ (pass-if-condition "read" i/o-read-error?
+ (read (make-failing-port))))
+ (with-test-prefix "write error"
+ (pass-if-condition "display" i/o-write-error?
+ (display "Hi there!" (make-failing-port)))
+ (pass-if-condition "write" i/o-write-error?
+ (write '(hi there!) (make-failing-port)))
+ (pass-if-condition "write-char" i/o-write-error?
+ (write-char #\G (make-failing-port)))
+ (pass-if-condition "newline" i/o-write-error?
+ (newline (make-failing-port))))
+ (let ((filename (test-file)))
+ ;; ensure the test file exists
+ (call-with-output-file filename
+ (lambda (port) (write "foo" port)))
+ (pass-if "call-with-input-file [port is textual]"
+ (call-with-input-file filename textual-port?))
+ (pass-if-condition "call-with-input-file [exception: not-found]"
+ i/o-file-does-not-exist-error?
+ (call-with-input-file ",this-is-highly-unlikely-to-exist!"
+ values))
+ (pass-if-condition "call-with-output-file [exception: already-exists]"
+ i/o-file-already-exists-error?
+ (call-with-output-file filename
+ values))
+ (delete-file filename)))
;;; Local Variables:
;;; mode: scheme