mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-21 19:20:21 +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

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