mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Merge remote-tracking branch 'origin/stable-2.0'

Browse source 
Conflicts:
	libguile/procprop.c
This commit is contained in:
Andy Wingo 2011-05-25 10:32:19 +02:00
commit a099c8d971
24 changed files with 469 additions and 282 deletions
Download patch file Download diff file Expand all files Collapse all files

9
doc/ref/api-debug.texi
View file

@ -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

14
doc/ref/api-evaluation.texi
View file

@ -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

8
doc/ref/api-io.texi
View file

@ -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

34
doc/ref/repl-modules.texi
View file

@ -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}).
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
@findex readline-options
@findex readline-enable
@findex readline-disable
@findex readline-set!
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.

11
libguile/Makefile.am
View file

@ -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

2
libguile/filesys.c
View file

@ -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;

12
libguile/goops.c
View file

@ -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);
}

10
libguile/procprop.c
View file

@ -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);

119
libguile/read.c
View file

@ -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,

15
libguile/smob.c
View file

@ -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;
}
}

59
libguile/srcprop.c
View file

@ -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

4
libguile/srcprop.h
View file

@ -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);

10
libguile/stime.c
View file

@ -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. */

19
libguile/symbols.c
View file

@ -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);
}

6
module/ice-9/boot-9.scm
View file

@ -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))

152
module/oop/goops.scm
View file

@ -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!}

78
module/rnrs/io/ports.scm
View file

@ -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)))
;;;

6
test-suite/standalone/Makefile.am
View file

@ -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}

31
test-suite/standalone/test-import-order Executable file
View file

@ -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:

4
test-suite/standalone/test-import-order-a.scm Normal file
View file

@ -0,0 +1,4 @@
(define-module (test-import-order-a)
#:use-module (base))
(push!)

4
test-suite/standalone/test-import-order-b.scm Normal file
View file

@ -0,0 +1,4 @@
(define-module (test-import-order-b)
#:use-module (base))
(push!)

4
test-suite/standalone/test-import-order-c.scm Normal file
View file

@ -0,0 +1,4 @@
(define-module (test-import-order-c)
#:use-module (base))
(push!)

4
test-suite/standalone/test-import-order-d.scm Normal file
View file

@ -0,0 +1,4 @@
(define-module (test-import-order-d)
#:use-module (base))
(push!)

136
test-suite/tests/r6rs-ports.test
View file

@ -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