mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-21 03:00:19 +02:00
Code Activity

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

Browse source 
Conflicts:
	GUILE-VERSION
	test-suite/tests/srfi-4.test
This commit is contained in:
Andy Wingo 2011-07-25 18:26:37 +02:00
commit ab4bc85398
73 changed files with 1292 additions and 335 deletions
Download patch file Download diff file Expand all files Collapse all files

1
libguile/Makefile.am
View file

@ -647,6 +647,7 @@ libpath.h: $(srcdir)/Makefile.in $(top_builddir)/config.status
@echo '#define SCM_LIB_DIR "$(libdir)"' >> libpath.tmp
@echo '#define SCM_EXTENSIONS_DIR "$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/extensions"' >> libpath.tmp
@echo '#define SCM_CCACHE_DIR "$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/ccache"' >> libpath.tmp
@echo '#define SCM_SITE_CCACHE_DIR "$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/site-ccache"' >> libpath.tmp
@echo '#define SCM_EFFECTIVE_VERSION "$(GUILE_EFFECTIVE_VERSION)"' >> libpath.tmp
@echo '#define SCM_BUILD_INFO { \' >> libpath.tmp
@echo ' { "srcdir", "'"`cd @srcdir@; pwd`"'" }, \' >> libpath.tmp

92
libguile/bytevectors.c
View file

@ -2109,26 +2109,56 @@ SCM_DEFINE (scm_utf32_to_string, "utf32->string",
/* Bytevectors as generalized vectors & arrays. */
#define COMPLEX_ACCESSOR_PROLOGUE(_type) \
size_t c_len, c_index; \
char *c_bv; \
\
SCM_VALIDATE_BYTEVECTOR (1, bv); \
c_index = scm_to_size_t (index); \
\
c_len = SCM_BYTEVECTOR_LENGTH (bv); \
c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
\
if (SCM_UNLIKELY (c_index + 2 * sizeof (_type) - 1 >= c_len)) \
scm_out_of_range (FUNC_NAME, index);
/* Template for native access to complex numbers of type TYPE. */
#define COMPLEX_NATIVE_REF(_type) \
SCM result; \
\
COMPLEX_ACCESSOR_PROLOGUE (_type); \
\
{ \
_type real, imag; \
\
memcpy (&real, &c_bv[c_index], sizeof (_type)); \
memcpy (&imag, &c_bv[c_index + sizeof (_type)], sizeof (_type)); \
\
result = scm_c_make_rectangular (real, imag); \
} \
\
return result;
static SCM
bytevector_ref_c32 (SCM bv, SCM idx)
{ /* FIXME add some checks */
const float *contents = (const float*)SCM_BYTEVECTOR_CONTENTS (bv);
size_t i = scm_to_size_t (idx);
return scm_c_make_rectangular (contents[i/4], contents[i/4 + 1]);
bytevector_ref_c32 (SCM bv, SCM index)
#define FUNC_NAME "bytevector_ref_c32"
{
COMPLEX_NATIVE_REF (float);
}
#undef FUNC_NAME
static SCM
bytevector_ref_c64 (SCM bv, SCM idx)
{ /* FIXME add some checks */
const double *contents = (const double*)SCM_BYTEVECTOR_CONTENTS (bv);
size_t i = scm_to_size_t (idx);
return scm_c_make_rectangular (contents[i/8], contents[i/8 + 1]);
bytevector_ref_c64 (SCM bv, SCM index)
#define FUNC_NAME "bytevector_ref_c64"
{
COMPLEX_NATIVE_REF (double);
}
#undef FUNC_NAME
typedef SCM (*scm_t_bytevector_ref_fn)(SCM, SCM);
const scm_t_bytevector_ref_fn bytevector_ref_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] =
static const scm_t_bytevector_ref_fn
bytevector_ref_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] =
{
NULL, /* SCM */
NULL, /* CHAR */
@ -2160,24 +2190,36 @@ bv_handle_ref (scm_t_array_handle *h, size_t index)
return ref_fn (h->array, byte_index);
}
/* FIXME add checks!!! */
static SCM
bytevector_set_c32 (SCM bv, SCM idx, SCM val)
{ float *contents = (float*)SCM_BYTEVECTOR_CONTENTS (bv);
size_t i = scm_to_size_t (idx);
contents[i/4] = scm_c_real_part (val);
contents[i/4 + 1] = scm_c_imag_part (val);
/* Template for native modification of complex numbers of type TYPE. */
#define COMPLEX_NATIVE_SET(_type) \
COMPLEX_ACCESSOR_PROLOGUE (_type); \
\
{ \
_type real, imag; \
real = scm_c_real_part (value); \
imag = scm_c_imag_part (value); \
\
memcpy (&c_bv[c_index], &real, sizeof (_type)); \
memcpy (&c_bv[c_index + sizeof (_type)], &imag, sizeof (_type)); \
} \
\
return SCM_UNSPECIFIED;
}
static SCM
bytevector_set_c64 (SCM bv, SCM idx, SCM val)
{ double *contents = (double*)SCM_BYTEVECTOR_CONTENTS (bv);
size_t i = scm_to_size_t (idx);
contents[i/8] = scm_c_real_part (val);
contents[i/8 + 1] = scm_c_imag_part (val);
return SCM_UNSPECIFIED;
bytevector_set_c32 (SCM bv, SCM index, SCM value)
#define FUNC_NAME "bytevector_set_c32"
{
COMPLEX_NATIVE_SET (float);
}
#undef FUNC_NAME
static SCM
bytevector_set_c64 (SCM bv, SCM index, SCM value)
#define FUNC_NAME "bytevector_set_c64"
{
COMPLEX_NATIVE_SET (double);
}
#undef FUNC_NAME
typedef SCM (*scm_t_bytevector_set_fn)(SCM, SCM, SCM);

28
libguile/filesys.c
View file

@ -261,8 +261,10 @@ SCM_DEFINE (scm_open, "open", 2, 1, 0,
fd = scm_to_int (scm_open_fdes (path, flags, mode));
iflags = SCM_NUM2INT (2, flags);
if (iflags & O_RDWR)
if ((iflags & O_RDWR) == O_RDWR)
{
/* Opened read-write. */
if (iflags & O_APPEND)
port_mode = "a+";
else if (iflags & O_CREAT)
@ -270,14 +272,17 @@ SCM_DEFINE (scm_open, "open", 2, 1, 0,
else
port_mode = "r+";
}
else {
if (iflags & O_APPEND)
port_mode = "a";
else if (iflags & O_WRONLY)
port_mode = "w";
else
port_mode = "r";
}
else
{
/* Opened read-only or write-only. */
if (iflags & O_APPEND)
port_mode = "a";
else if (iflags & O_WRONLY)
port_mode = "w";
else
port_mode = "r";
}
newpt = scm_fdes_to_port (fd, port_mode, path);
return newpt;
}
@ -1856,7 +1861,10 @@ scm_init_filesys ()
#endif
#ifdef O_LARGEFILE
scm_c_define ("O_LARGEFILE", scm_from_int (O_LARGEFILE));
#endif
#endif
#ifdef O_NOTRANS
scm_c_define ("O_NOTRANS", scm_from_int (O_NOTRANS));
#endif
#ifdef F_DUPFD
scm_c_define ("F_DUPFD", scm_from_int (F_DUPFD));

15
libguile/goops.c
View file

@ -2284,15 +2284,21 @@ SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0,
*
******************************************************************************/
/* Munge the CPL of C in place such that BEFORE appears before AFTER,
assuming that currently the reverse is true. Recalculate slots and
associated getters-n-setters. */
static void
fix_cpl (SCM c, SCM before, SCM after)
{
SCM cpl = SCM_SLOT (c, scm_si_cpl);
SCM ls = scm_c_memq (after, cpl);
SCM tail = scm_delq1_x (before, SCM_CDR (ls));
SCM tail;
if (scm_is_false (ls))
/* if this condition occurs, fix_cpl should not be applied this way */
abort ();
tail = scm_delq1_x (before, SCM_CDR (ls));
SCM_SETCAR (ls, before);
SCM_SETCDR (ls, scm_cons (after, tail));
{
@ -2418,8 +2424,8 @@ create_standard_classes (void)
make_stdcls (&scm_class_extended_generic_with_setter,
"<extended-generic-with-setter>",
scm_class_applicable_struct_class,
scm_list_2 (scm_class_generic_with_setter,
scm_class_extended_generic),
scm_list_2 (scm_class_extended_generic,
scm_class_generic_with_setter),
SCM_EOL);
SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter,
SCM_CLASSF_PURE_GENERIC);
@ -2428,8 +2434,9 @@ create_standard_classes (void)
scm_list_2 (scm_class_accessor,
scm_class_extended_generic_with_setter),
SCM_EOL);
/* <extended-generic> is misplaced. */
fix_cpl (scm_class_extended_accessor,
scm_class_extended_generic, scm_class_generic);
scm_class_extended_generic, scm_class_generic_with_setter);
SCM_SET_CLASS_FLAGS (scm_class_extended_accessor, SCM_CLASSF_PURE_GENERIC);
/* Primitive types classes */

2
libguile/i18n.c
View file

@ -400,7 +400,7 @@ install_locale (scm_t_locale locale)
account. */
category_mask |= locale->category_mask;
if (locale->base_locale != SCM_UNDEFINED)
if (!SCM_UNBNDP (locale->base_locale))
locale = (scm_t_locale) SCM_SMOB_DATA (locale->base_locale);
else
locale = NULL;

25
libguile/load.c
View file

@ -270,7 +270,10 @@ scm_init_load_path ()
else if (env)
cpath = scm_parse_path (scm_from_locale_string (env), cpath);
else
cpath = scm_cons (scm_from_locale_string (SCM_CCACHE_DIR), cpath);
{
cpath = scm_list_2 (scm_from_locale_string (SCM_CCACHE_DIR),
scm_from_locale_string (SCM_SITE_CCACHE_DIR));
}
#endif /* SCM_LIBRARY_DIR */
@ -793,6 +796,22 @@ scm_try_auto_compile (SCM source)
NULL, NULL);
}
/* See also (system base compile):compiled-file-name. */
static SCM
canonical_to_suffix (SCM canon)
{
size_t len = scm_c_string_length (canon);
if (len > 1 && scm_is_eq (scm_c_string_ref (canon, 0), SCM_MAKE_CHAR ('/')))
return canon;
else if (len > 2 && scm_is_eq (scm_c_string_ref (canon, 1), SCM_MAKE_CHAR (':')))
return scm_string_append (scm_list_3 (scm_from_latin1_string ("/"),
scm_c_substring (canon, 0, 1),
scm_c_substring (canon, 2, len)));
else
return canon;
}
SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
(SCM args),
"Search @var{%load-path} for the file named @var{filename} and\n"
@ -857,7 +876,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
{
SCM fallback = scm_string_append
(scm_list_3 (*scm_loc_compile_fallback_path,
full_filename,
canonical_to_suffix (full_filename),
scm_car (*scm_loc_load_compiled_extensions)));
if (scm_is_true (scm_stat (fallback, SCM_BOOL_F)))
{
@ -895,7 +914,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
{
SCM fallback = scm_string_append
(scm_list_3 (*scm_loc_compile_fallback_path,
full_filename,
canonical_to_suffix (full_filename),
scm_car (*scm_loc_load_compiled_extensions)));
if (scm_is_true (scm_stat (fallback, SCM_BOOL_F))
&& compiled_is_fresh (full_filename, fallback))

73
libguile/modules.c
View file

@ -294,39 +294,46 @@ resolve_duplicate_binding (SCM module, SCM sym,
SCM iface1, SCM var1,
SCM iface2, SCM var2)
{
SCM args[8];
SCM handlers;
SCM result = SCM_BOOL_F;
if (!scm_is_eq (var1, var2))
if (scm_is_eq (var1, var2))
return var1;
args[0] = module;
args[1] = sym;
args[2] = iface1;
args[3] = SCM_VARIABLE_REF (var1);
if (SCM_UNBNDP (args[3]))
args[3] = SCM_BOOL_F;
args[4] = iface2;
args[5] = SCM_VARIABLE_REF (var2);
if (SCM_UNBNDP (args[5]))
args[5] = SCM_BOOL_F;
args[6] = scm_hashq_ref (SCM_MODULE_IMPORT_OBARRAY (module), sym, SCM_BOOL_F);
args[7] = SCM_BOOL_F;
handlers = SCM_MODULE_DUPLICATE_HANDLERS (module);
if (scm_is_false (handlers))
handlers = default_duplicate_binding_handlers ();
for (; scm_is_pair (handlers); handlers = SCM_CDR (handlers))
{
SCM val1, val2;
SCM handlers, h, handler_args;
if (scm_is_true (args[6]))
{
args[7] = SCM_VARIABLE_REF (args[6]);
if (SCM_UNBNDP (args[7]))
args[7] = SCM_BOOL_F;
}
result = scm_call_n (SCM_CAR (handlers), args, 8);
val1 = SCM_VARIABLE_REF (var1);
val2 = SCM_VARIABLE_REF (var2);
val1 = scm_is_eq (val1, SCM_UNSPECIFIED) ? SCM_BOOL_F : val1;
val2 = scm_is_eq (val2, SCM_UNSPECIFIED) ? SCM_BOOL_F : val2;
handlers = SCM_MODULE_DUPLICATE_HANDLERS (module);
if (scm_is_false (handlers))
handlers = default_duplicate_binding_handlers ();
handler_args = scm_list_n (module, sym,
iface1, val1, iface2, val2,
var1, val1,
SCM_UNDEFINED);
for (h = handlers;
scm_is_pair (h) && scm_is_false (result);
h = SCM_CDR (h))
{
result = scm_apply (SCM_CAR (h), handler_args, SCM_EOL);
}
if (scm_is_true (result))
return result;
}
else
result = var1;
return result;
return SCM_BOOL_F;
}
/* No lock is needed for access to this variable, as there are no
@ -368,9 +375,15 @@ module_imported_variable (SCM module, SCM sym)
{
/* SYM is a duplicate binding (imported more than once) so we
need to resolve it. */
found_var = resolve_duplicate_binding (module, sym,
found_iface, found_var,
iface, var);
found_var = resolve_duplicate_binding (module, sym,
found_iface, found_var,
iface, var);
/* Note that it could be that FOUND_VAR doesn't belong
either to FOUND_IFACE or to IFACE, if it was created
by merge-generics. The right thing to do there would
be to treat the import obarray as the iface, but the
import obarray isn't actually a module. Oh well. */
if (scm_is_eq (found_var, var))
found_iface = iface;
}

11
libguile/read.c
View file

@ -376,8 +376,12 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
return SCM_EOL;
scm_ungetc (c, port);
if (scm_is_eq (scm_sym_dot,
(tmp = scm_read_expression (port))))
tmp = scm_read_expression (port);
/* Note that it is possible for scm_read_expression to return
scm_sym_dot, but not as part of a dotted pair: as in #{.}#. So
check that it's a real dot by checking `c'. */
if (c == '.' && scm_is_eq (scm_sym_dot, tmp))
{
ans = scm_read_expression (port);
if (terminating_char != (c = flush_ws (port, FUNC_NAME)))
@ -401,7 +405,8 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
scm_ungetc (c, port);
tmp = scm_read_expression (port);
if (scm_is_eq (scm_sym_dot, tmp))
/* See above note about scm_sym_dot. */
if (c == '.' && scm_is_eq (scm_sym_dot, tmp))
{
SCM_SETCDR (tl, tmp = scm_read_expression (port));

18
libguile/threads.c
View file

@ -692,6 +692,10 @@ on_thread_exit (void *v)
/* This handler is executed in non-guile mode. */
scm_i_thread *t = (scm_i_thread *) v, **tp;
/* If we were canceled, we were unable to clear `t->guile_mode', so do
it here. */
t->guile_mode = 0;
/* If this thread was cancelled while doing a cond wait, it will
still have a mutex locked, so we unlock it here. */
if (t->held_mutex)
@ -831,12 +835,6 @@ scm_init_guile ()
}
}
SCM_UNUSED static void
scm_leave_guile_cleanup (void *x)
{
on_thread_exit (SCM_I_CURRENT_THREAD);
}
struct with_guile_args
{
GC_fn_type func;
@ -1368,7 +1366,9 @@ fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, SCM owner, int *ret)
{
scm_i_thread *t = SCM_I_THREAD_DATA (new_owner);
scm_i_pthread_mutex_unlock (&m->lock);
/* FIXME: The order in which `t->admin_mutex' and
`m->lock' are taken differs from that in
`on_thread_exit', potentially leading to deadlocks. */
scm_i_pthread_mutex_lock (&t->admin_mutex);
/* Only keep a weak reference to MUTEX so that it's not
@ -1379,7 +1379,6 @@ fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, SCM owner, int *ret)
t->mutexes = scm_weak_car_pair (mutex, t->mutexes);
scm_i_pthread_mutex_unlock (&t->admin_mutex);
scm_i_pthread_mutex_lock (&m->lock);
}
*ret = 1;
break;
@ -1458,6 +1457,9 @@ SCM_DEFINE (scm_lock_mutex_timed, "lock-mutex", 1, 2, 0,
waittime = &cwaittime;
}
if (!SCM_UNBNDP (owner) && !scm_is_false (owner))
SCM_VALIDATE_THREAD (3, owner);
exception = fat_mutex_lock (m, waittime, owner, &ret);
if (!scm_is_false (exception))
scm_ithrow (SCM_CAR (exception), scm_list_1 (SCM_CDR (exception)), 1);

18
libguile/vm-engine.c
View file

@ -61,23 +61,31 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
SCM finish_args; /* used both for returns: both in error
and normal situations */
#ifdef HAVE_LABELS_AS_VALUES
static void **jump_table = NULL;
static const void **jump_table_pointer = NULL;
#endif
#ifdef HAVE_LABELS_AS_VALUES
if (SCM_UNLIKELY (!jump_table))
register const void **jump_table JT_REG;
if (SCM_UNLIKELY (!jump_table_pointer))
{
int i;
jump_table = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof(void*));
jump_table_pointer = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof (void*));
for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
jump_table[i] = &&vm_error_bad_instruction;
jump_table_pointer[i] = &&vm_error_bad_instruction;
#define VM_INSTRUCTION_TO_LABEL 1
#define jump_table jump_table_pointer
#include <libguile/vm-expand.h>
#include <libguile/vm-i-system.i>
#include <libguile/vm-i-scheme.i>
#include <libguile/vm-i-loader.i>
#undef jump_table
#undef VM_INSTRUCTION_TO_LABEL
}
/* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one
load instruction at each instruction dispatch. */
jump_table = jump_table_pointer;
#endif
/* Initialization */

8
libguile/vm-engine.h
View file

@ -57,6 +57,11 @@
/* too few registers! because of register allocation errors with various gcs,
just punt on explicit assignments on i386, hoping that the "register"
declaration will be sufficient. */
#elif defined __x86_64__
/* GCC 4.6 chooses %rbp for IP_REG and %rbx for SP_REG, which works
well. Tell it to keep the jump table in a r12, which is
callee-saved. */
#define JT_REG asm ("r12")
#endif
#if defined(PPC) || defined(_POWER) || defined(_IBMR2)
#define IP_REG asm("26")
@ -89,6 +94,9 @@
#ifndef FP_REG
#define FP_REG
#endif
#ifndef JT_REG
#define JT_REG
#endif
/*