[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-63-ga099c8d
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-63-ga099c8d |
|
Date: |
Wed, 25 May 2011 08:56:34 +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=a099c8d971c1d5b32e00f25469b36ce45fd4d8c7
The branch, master has been updated
via a099c8d971c1d5b32e00f25469b36ce45fd4d8c7 (commit)
via 7ad0737de9b7bbb5f4f938518b4905b526d13ca6 (commit)
via ea742d29c50c6fc4a4c03288c4ddbe33f24f1913 (commit)
via 2f045fc1f6e53fa9bcaa821c18ec49b19560fe4e (commit)
via 26c8cc144f4d58871098347df7462ea60b72a72c (commit)
via c0937f0988d202d1062fea6e5b61d68d387d1542 (commit)
via f2ed447383f0398777719a2cda92c38e9838bf85 (commit)
via b34608813de5fce7f8caee63bdbaeab445eb366e (commit)
via 2a3db25e283a6b8e30d9761546605e7cae757c67 (commit)
via ad4bd7c2c0c931a91160772e5ebf40af0f471874 (commit)
via 0dd8493cb33e69d202f93810a39279c988bd2d95 (commit)
via a02a606716d782e0351e5abc5b0f70ebc3d18ac8 (commit)
via 19761af161942ef18aa2b7891cbf718fc5be5945 (commit)
via a04e57498c7d7223315e39c34cc8d5e3bf8d5e0b (commit)
via 1233b38393c776d48cfc4c91d9c514ea7f3762f3 (commit)
via b6a66c21fc3791bb5ea50f6e7a0ccc2e8f55e27a (commit)
from 9ec1573d2b9463043df79b9a2cb30acc6afaeaaa (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 a099c8d971c1d5b32e00f25469b36ce45fd4d8c7
Merge: 9ec1573 7ad0737
Author: Andy Wingo <address@hidden>
Date: Wed May 25 10:32:19 2011 +0200
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts:
libguile/procprop.c
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-debug.texi | 9 +-
doc/ref/api-evaluation.texi | 14 ++-
doc/ref/api-io.texi | 8 --
doc/ref/repl-modules.texi | 36 +++----
libguile/Makefile.am | 11 ++-
libguile/filesys.c | 2 +-
libguile/goops.c | 12 ++-
libguile/procprop.c | 10 ++-
libguile/read.c | 119 ++------------------
libguile/smob.c | 15 ++-
libguile/srcprop.c | 59 +++++++++-
libguile/srcprop.h | 4 +-
libguile/stime.c | 10 +-
libguile/symbols.c | 19 +--
module/ice-9/boot-9.scm | 6 +-
module/oop/goops.scm | 152 ++++++++++++-------------
module/rnrs/io/ports.scm | 78 ++++++++-----
test-suite/standalone/Makefile.am | 6 +
test-suite/standalone/test-import-order | 31 +++++
test-suite/standalone/test-import-order-a.scm | 4 +
test-suite/standalone/test-import-order-b.scm | 4 +
test-suite/standalone/test-import-order-c.scm | 4 +
test-suite/standalone/test-import-order-d.scm | 4 +
test-suite/tests/r6rs-ports.test | 136 ++++++++++++++++++++++-
24 files changed, 470 insertions(+), 283 deletions(-)
create mode 100755 test-suite/standalone/test-import-order
create mode 100644 test-suite/standalone/test-import-order-a.scm
create mode 100644 test-suite/standalone/test-import-order-b.scm
create mode 100644 test-suite/standalone/test-import-order-c.scm
create mode 100644 test-suite/standalone/test-import-order-d.scm
diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi
index 765b4ad..bdb6166 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.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007,
2010
address@hidden 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
address@hidden {Scheme Procedure} debug-set! option-name value
address@hidden {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.
address@hidden can be used to set an option to a specific value.
+
address@hidden 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 9430c74..e873310 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
address@hidden {Scheme Procedure} read-set! option-name value
address@hidden {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.
address@hidden can be used to set an option to a specific value.
+
address@hidden 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.
address@hidden {Scheme Procedure} print-set! option-name value
-Modify the print options.
address@hidden {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 09fdc83..19c0665 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
address@hidden {Scheme Procedure} print-options-interface [setting]
address@hidden {C Function} scm_print_options (setting)
-Option interface for the print options. Instead of using
-this procedure directly, use the procedures
address@hidden, @code{print-disable}, @code{print-set!}
-and @code{print-options}.
address@hidden 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 78c7eee..7008672 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.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2010
address@hidden 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
address@hidden 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}).
-
address@hidden readline-options
address@hidden readline-enable
address@hidden readline-disable
address@hidden 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}).
+
address@hidden {Scheme Procedure} readline-options
address@hidden {Scheme Procedure} readline-enable option-name
address@hidden {Scheme Procedure} readline-disable option-name
address@hidden {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.
address@hidden 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.
-
address@hidden
-(readline-disable 'history)
address@hidden 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 263d6b0..6f2f793 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 b43536f..2429e80 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 925f094..8ed37fa 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 39f5737..ac2fa12 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 098854b..6e7804d 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 adb34ba..c414913 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 4eb1cca..dc333d4 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 5c9ccb9..250756d 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 1c4f407..dda82e7 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 2a1b46d..59aca00 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 6dab79e..0493de5 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 2801aa2..1f9fd50 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 3dbaa03..4ae01be 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 cf1fc4f..00655bd 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 0000000..8b51312
--- /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 0000000..d6fa29d
--- /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 0000000..bc41bdf
--- /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 0000000..4b58c3d
--- /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 0000000..fb071be
--- /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 06431bb..7a382b7 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
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-63-ga099c8d,
Andy Wingo <=