mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

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

Browse source
This commit is contained in:
Andy Wingo 2011-05-05 14:09:29 +02:00
commit 891a1851a1
41 changed files with 1177 additions and 705 deletions
Download patch file Download diff file Expand all files Collapse all files

32
acinclude.m4
View file

@ -502,3 +502,35 @@ AC_DEFUN([GUILE_LIBUNISTRING_WITH_ICONV_SUPPORT], [
dnl Declare file $1 to be a script that needs configuring,
dnl and arrange to make it executable in the process.
AC_DEFUN([GUILE_CONFIG_SCRIPT],[AC_CONFIG_FILES([$1],[chmod +x $1])])
# clock_time.m4 serial 10
dnl Copyright (C) 2002-2006, 2009-2011 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
# Check for clock_gettime and clock_settime, and set LIB_CLOCK_GETTIME.
# For a program named, say foo, you should add a line like the following
# in the corresponding Makefile.am file:
# foo_LDADD = $(LDADD) $(LIB_CLOCK_GETTIME)
AC_DEFUN([gl_CLOCK_TIME],
[
dnl Persuade glibc and Solaris <time.h> to declare these functions.
AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
# Solaris 2.5.1 needs -lposix4 to get the clock_gettime function.
# Solaris 7 prefers the library name -lrt to the obsolescent name -lposix4.
# Save and restore LIBS so e.g., -lrt, isn't added to it. Otherwise, *all*
# programs in the package would end up linked with that potentially-shared
# library, inducing unnecessary run-time overhead.
LIB_CLOCK_GETTIME=
AC_SUBST([LIB_CLOCK_GETTIME])
gl_saved_libs=$LIBS
AC_SEARCH_LIBS([clock_gettime], [rt posix4],
[test "$ac_cv_search_clock_gettime" = "none required" ||
LIB_CLOCK_GETTIME=$ac_cv_search_clock_gettime])
AC_CHECK_FUNCS([clock_gettime clock_settime])
LIBS=$gl_saved_libs
])

67
configure.ac
View file

@ -65,6 +65,9 @@ AC_PROG_AWK
dnl Gnulib.
gl_INIT
dnl FIXME: remove me and the acinclude.m4 code when clock-gettime is
dnl LGPL-compatible and can be imported normally.
gl_CLOCK_TIME
AC_PROG_CC_C89
@ -1191,6 +1194,70 @@ AC_CHECK_MEMBERS([struct tm.tm_gmtoff],,,
GUILE_STRUCT_UTIMBUF
#--------------------------------------------------------------------
#
# What values do the iconv error handlers have?
#
# The only place that we need iconv in our public interfaces is for
# the error handlers, which are just ints. So we weaken our
# dependency by looking up those values at configure-time.
#--------------------------------------------------------------------
SCM_I_GSC_ICONVEH_ERROR=0
SCM_I_GSC_ICONVEH_QUESTION_MARK=1
SCM_I_GSC_ICONVEH_ESCAPE_SEQUENCE=2
AC_MSG_CHECKING([for iconveh_error])
AC_RUN_IFELSE([AC_LANG_SOURCE(
[AC_INCLUDES_DEFAULT
#include <uniconv.h>
int
main (int argc, char *argv[])
{
if (argc > 1)
printf ("%d\n", (int)iconveh_error);
return 0;
}])],
[SCM_I_GSC_ICONVEH_ERROR=`./conftest$EXEEXT pretty-please`
AC_MSG_RESULT([$SCM_I_GSC_ICONVEH_ERROR])],
[AC_MSG_FAILURE([failed to get iconveh_error])],
[AC_MSG_WARN([assuming $SCM_I_GSC_ICONVEH_ERROR for cross-compilation])])
AC_MSG_CHECKING([for iconveh_question_mark])
AC_RUN_IFELSE([AC_LANG_SOURCE(
[AC_INCLUDES_DEFAULT
#include <uniconv.h>
int
main (int argc, char *argv[])
{
if (argc > 1)
printf ("%d\n", (int)iconveh_question_mark);
return 0;
}])],
[SCM_I_GSC_ICONVEH_QUESTION_MARK=`./conftest$EXEEXT pretty-please`
AC_MSG_RESULT([$SCM_I_GSC_ICONVEH_QUESTION_MARK])],
[AC_MSG_FAILURE([failed to get iconveh_question_mark])],
[AC_MSG_WARN([assuming $SCM_I_GSC_ICONVEH_QUESTION_MARK for cross-compilation])])
AC_MSG_CHECKING([for iconveh_escape_sequence])
AC_RUN_IFELSE([AC_LANG_SOURCE(
[AC_INCLUDES_DEFAULT
#include <uniconv.h>
int
main (int argc, char *argv[])
{
if (argc > 1)
printf ("%d\n", (int)iconveh_escape_sequence);
return 0;
}])],
[SCM_I_GSC_ICONVEH_ESCAPE_SEQUENCE=`./conftest$EXEEXT pretty-please`
AC_MSG_RESULT([$SCM_I_GSC_ICONVEH_ESCAPE_SEQUENCE])],
[AC_MSG_FAILURE([failed to get iconveh_escape_sequence])],
[AC_MSG_WARN([assuming $SCM_I_GSC_ICONVEH_ESCAPE_SEQUENCE for cross-compilation])])
AC_SUBST([SCM_I_GSC_ICONVEH_ERROR])
AC_SUBST([SCM_I_GSC_ICONVEH_QUESTION_MARK])
AC_SUBST([SCM_I_GSC_ICONVEH_ESCAPE_SEQUENCE])
#--------------------------------------------------------------------
#
# Which way does the stack grow?

2
doc/ref/api-control.texi
View file

@ -290,7 +290,7 @@ expression, as multiple values. Otherwise if it terminates by a call to
@example
(while #f (error "not reached")) @result{} #f
(while #t (break)) @result{} #t
(while #f (break 1 2 3)) @result{} 1 2 3
(while #t (break 1 2 3)) @result{} 1 2 3
@end example
Each @code{while} form gets its own @code{break} and @code{continue}

13
libguile/Makefile.am
View file

@ -55,13 +55,11 @@ 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
gen-scmconfig.$(OBJEXT): gen-scmconfig.c
$(AM_V_GEN) \
if [ "$(cross_compiling)" = "yes" ]; then \
$(CC_FOR_BUILD) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) \
$(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) \
-c -o $@ $<; \
else \
$(COMPILE) -c -o $@ $<; \
$(AM_V_GEN) \
if [ "$(cross_compiling)" = "yes" ]; then \
$(CC_FOR_BUILD) $(DEFS) $(DEFAULT_INCLUDES) $(AM_CPPFLAGS) -c -o $@ $<; \
else \
$(COMPILE) -c -o $@ $<; \
fi
## Override default rule; this should run on BUILD host.
@ -474,6 +472,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_LDFLAGS = \
$(ISNANF_LIBM) \
$(ISNANL_LIBM) \
$(LDEXP_LIBM) \
$(LIB_CLOCK_GETTIME) \
$(LIBSOCKET) \
$(LOG1P_LIBM) \
$(LTLIBICONV) \

113
libguile/deprecated.c
View file

@ -2425,17 +2425,17 @@ SCM_DEFINE (scm_primitive_property_ref, "primitive-property-ref", 2, 0, 0,
"property value.")
#define FUNC_NAME s_scm_primitive_property_ref
{
SCM h;
SCM alist;
scm_c_issue_deprecation_warning
("`primitive-property-ref' is deprecated. Use object properties.");
SCM_VALIDATE_CONS (SCM_ARG1, prop);
h = scm_hashq_get_handle (properties_whash, obj);
if (scm_is_true (h))
alist = scm_hashq_ref (properties_whash, obj, SCM_EOL);
if (scm_is_pair (alist))
{
SCM assoc = scm_assq (prop, SCM_CDR (h));
SCM assoc = scm_assq (prop, alist);
if (scm_is_true (assoc))
return SCM_CDR (assoc);
}
@ -2445,9 +2445,8 @@ SCM_DEFINE (scm_primitive_property_ref, "primitive-property-ref", 2, 0, 0,
else
{
SCM val = scm_call_2 (SCM_CAR (prop), prop, obj);
if (scm_is_false (h))
h = scm_hashq_create_handle_x (properties_whash, obj, SCM_EOL);
SCM_SETCDR (h, scm_acons (prop, val, SCM_CDR (h)));
scm_hashq_set_x (properties_whash, obj,
scm_acons (prop, val, alist));
return val;
}
}
@ -2459,21 +2458,19 @@ SCM_DEFINE (scm_primitive_property_set_x, "primitive-property-set!", 3, 0, 0,
"Set the property @var{prop} of @var{obj} to @var{val}.")
#define FUNC_NAME s_scm_primitive_property_set_x
{
SCM h, assoc;
SCM alist, assoc;
scm_c_issue_deprecation_warning
("`primitive-property-set!' is deprecated. Use object properties.");
SCM_VALIDATE_CONS (SCM_ARG1, prop);
h = scm_hashq_create_handle_x (properties_whash, obj, SCM_EOL);
assoc = scm_assq (prop, SCM_CDR (h));
if (SCM_NIMP (assoc))
alist = scm_hashq_ref (properties_whash, obj, SCM_EOL);
assoc = scm_assq (prop, alist);
if (scm_is_pair (assoc))
SCM_SETCDR (assoc, val);
else
{
assoc = scm_acons (prop, val, SCM_CDR (h));
SCM_SETCDR (h, assoc);
}
scm_hashq_set_x (properties_whash, obj,
scm_acons (prop, val, alist));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@ -2484,26 +2481,104 @@ SCM_DEFINE (scm_primitive_property_del_x, "primitive-property-del!", 2, 0, 0,
"Remove any value associated with @var{prop} and @var{obj}.")
#define FUNC_NAME s_scm_primitive_property_del_x
{
SCM h;
SCM alist;
scm_c_issue_deprecation_warning
("`primitive-property-del!' is deprecated. Use object properties.");
SCM_VALIDATE_CONS (SCM_ARG1, prop);
h = scm_hashq_get_handle (properties_whash, obj);
if (scm_is_true (h))
SCM_SETCDR (h, scm_assq_remove_x (SCM_CDR (h), prop));
alist = scm_hashq_ref (properties_whash, obj, SCM_EOL);
if (scm_is_pair (alist))
scm_hashq_set_x (properties_whash, obj, scm_assq_remove_x (alist, prop));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM
scm_whash_get_handle (SCM whash, SCM key)
{
scm_c_issue_deprecation_warning
("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
return scm_hashq_get_handle (whash, key);
}
int
SCM_WHASHFOUNDP (SCM h)
{
scm_c_issue_deprecation_warning
("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
return scm_is_true (h);
}
SCM
SCM_WHASHREF (SCM whash, SCM handle)
{
scm_c_issue_deprecation_warning
("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
return SCM_CDR (handle);
}
void
SCM_WHASHSET (SCM whash, SCM handle, SCM obj)
{
scm_c_issue_deprecation_warning
("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
SCM_SETCDR (handle, obj);
}
SCM
scm_whash_create_handle (SCM whash, SCM key)
{
scm_c_issue_deprecation_warning
("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
return scm_hashq_create_handle_x (whash, key, SCM_UNSPECIFIED);
}
SCM
scm_whash_lookup (SCM whash, SCM obj)
{
scm_c_issue_deprecation_warning
("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
return scm_hashq_ref (whash, obj, SCM_BOOL_F);
}
void
scm_whash_insert (SCM whash, SCM key, SCM obj)
{
scm_c_issue_deprecation_warning
("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
scm_hashq_set_x (whash, key, obj);
}
SCM scm_struct_table = SCM_BOOL_F;
SCM
scm_struct_create_handle (SCM obj)
{
scm_c_issue_deprecation_warning
("`scm_struct_create_handle' is deprecated, and has no effect.");
return scm_cons (obj, scm_cons (SCM_BOOL_F, SCM_BOOL_F));
}
void
scm_i_init_deprecated ()
{
properties_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
scm_struct_table = scm_make_hash_table (SCM_UNDEFINED);
#include "libguile/deprecated.x"
}

31
libguile/deprecated.h
View file

@ -750,6 +750,37 @@ SCM_DEPRECATED SCM scm_primitive_property_ref (SCM prop, SCM obj);
SCM_DEPRECATED SCM scm_primitive_property_set_x (SCM prop, SCM obj, SCM val);
SCM_DEPRECATED SCM scm_primitive_property_del_x (SCM prop, SCM obj);
/* {The old whash table interface}
* Deprecated, as the hash table interface is sufficient, and accessing
* handles of weak hash tables is no longer supported.
*/
#define scm_whash_handle SCM
SCM_DEPRECATED SCM scm_whash_get_handle (SCM whash, SCM key);
SCM_DEPRECATED int SCM_WHASHFOUNDP (SCM h);
SCM_DEPRECATED SCM SCM_WHASHREF (SCM whash, SCM handle);
SCM_DEPRECATED void SCM_WHASHSET (SCM whash, SCM handle, SCM obj);
SCM_DEPRECATED SCM scm_whash_create_handle (SCM whash, SCM key);
SCM_DEPRECATED SCM scm_whash_lookup (SCM whash, SCM obj);
SCM_DEPRECATED void scm_whash_insert (SCM whash, SCM key, SCM obj);
/* No need for a table for names, and the struct->class mapping is
maintained by GOOPS now. */
#define SCM_STRUCT_TABLE_NAME(X) SCM_CAR (X)
#define SCM_SET_STRUCT_TABLE_NAME(X, NAME) SCM_SETCAR (X, NAME)
#define SCM_STRUCT_TABLE_CLASS(X) SCM_CDR (X)
#define SCM_SET_STRUCT_TABLE_CLASS(X, CLASS) SCM_SETCDR (X, CLASS)
SCM_DEPRECATED SCM scm_struct_table;
SCM_DEPRECATED SCM scm_struct_create_handle (SCM obj);
void scm_i_init_deprecated (void);

85
libguile/eval.c
View file

@ -175,6 +175,32 @@ static void error_unrecognized_keyword (SCM proc)
}
/* Multiple values truncation. */
static SCM
truncate_values (SCM x)
{
if (SCM_LIKELY (!SCM_VALUESP (x)))
return x;
else
{
SCM l = scm_struct_ref (x, SCM_INUM0);
if (SCM_LIKELY (scm_is_pair (l)))
return scm_car (l);
else
{
scm_ithrow (scm_from_latin1_symbol ("vm-run"),
scm_list_3 (scm_from_latin1_symbol ("vm-run"),
scm_from_locale_string
("Too few values returned to continuation"),
SCM_EOL),
1);
/* Not reached. */
return SCM_BOOL_F;
}
}
}
#define EVAL1(x, env) (truncate_values (eval ((x), (env))))
/* the environment:
(VAL ... . MOD)
If MOD is #f, it means the environment was captured before modules were
@ -209,7 +235,7 @@ eval (SCM x, SCM env)
goto loop;
case SCM_M_IF:
if (scm_is_true (eval (CAR (mx), env)))
if (scm_is_true (EVAL1 (CAR (mx), env)))
x = CADR (mx);
else
x = CDDR (mx);
@ -220,7 +246,8 @@ eval (SCM x, SCM env)
SCM inits = CAR (mx);
SCM new_env = CAPTURE_ENV (env);
for (; scm_is_pair (inits); inits = CDR (inits))
new_env = scm_cons (eval (CAR (inits), env), new_env);
new_env = scm_cons (EVAL1 (CAR (inits), env),
new_env);
env = new_env;
x = CDR (mx);
goto loop;
@ -233,14 +260,14 @@ eval (SCM x, SCM env)
return mx;
case SCM_M_DEFINE:
scm_define (CAR (mx), eval (CDR (mx), env));
scm_define (CAR (mx), EVAL1 (CDR (mx), env));
return SCM_UNSPECIFIED;
case SCM_M_DYNWIND:
{
SCM in, out, res, old_winds;
in = eval (CAR (mx), env);
out = eval (CDDR (mx), env);
in = EVAL1 (CAR (mx), env);
out = EVAL1 (CDDR (mx), env);
scm_call_0 (in);
old_winds = scm_i_dynwinds ();
scm_i_set_dynwinds (scm_acons (in, out, old_winds));
@ -257,10 +284,10 @@ eval (SCM x, SCM env)
len = scm_ilength (CAR (mx));
fluidv = alloca (sizeof (SCM)*len);
for (i = 0, walk = CAR (mx); i < len; i++, walk = CDR (walk))
fluidv[i] = eval (CAR (walk), env);
fluidv[i] = EVAL1 (CAR (walk), env);
valuesv = alloca (sizeof (SCM)*len);
for (i = 0, walk = CADR (mx); i < len; i++, walk = CDR (walk))
valuesv[i] = eval (CAR (walk), env);
valuesv[i] = EVAL1 (CAR (walk), env);
wf = scm_i_make_with_fluids (len, fluidv, valuesv);
scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
@ -274,9 +301,9 @@ eval (SCM x, SCM env)
case SCM_M_APPLY:
/* Evaluate the procedure to be applied. */
proc = eval (CAR (mx), env);
proc = EVAL1 (CAR (mx), env);
/* Evaluate the argument holding the list of arguments */
args = eval (CADR (mx), env);
args = EVAL1 (CADR (mx), env);
apply_proc:
/* Go here to tail-apply a procedure. PROC is the procedure and
@ -291,7 +318,7 @@ eval (SCM x, SCM env)
case SCM_M_CALL:
/* Evaluate the procedure to be applied. */
proc = eval (CAR (mx), env);
proc = EVAL1 (CAR (mx), env);
argc = SCM_I_INUM (CADR (mx));
mx = CDDR (mx);
@ -307,21 +334,22 @@ eval (SCM x, SCM env)
argv = alloca (argc * sizeof (SCM));
for (i = 0; i < argc; i++, mx = CDR (mx))
argv[i] = eval (CAR (mx), env);
argv[i] = EVAL1 (CAR (mx), env);
return scm_c_vm_run (scm_the_vm (), proc, argv, argc);
}
case SCM_M_CONT:
return scm_i_call_with_current_continuation (eval (mx, env));
return scm_i_call_with_current_continuation (EVAL1 (mx, env));
case SCM_M_CALL_WITH_VALUES:
{
SCM producer;
SCM v;
producer = eval (CAR (mx), env);
proc = eval (CDR (mx), env); /* proc is the consumer. */
producer = EVAL1 (CAR (mx), env);
/* `proc' is the consumer. */
proc = EVAL1 (CDR (mx), env);
v = scm_call_with_vm (scm_the_vm (), producer, SCM_EOL);
if (SCM_VALUESP (v))
args = scm_struct_ref (v, SCM_INUM0);
@ -347,7 +375,7 @@ eval (SCM x, SCM env)
case SCM_M_LEXICAL_SET:
{
int n;
SCM val = eval (CDR (mx), env);
SCM val = EVAL1 (CDR (mx), env);
for (n = SCM_I_INUM (CAR (mx)); n; n--)
env = CDR (env);
SCM_SETCAR (env, val);
@ -368,7 +396,7 @@ eval (SCM x, SCM env)
case SCM_M_TOPLEVEL_SET:
{
SCM var = CAR (mx);
SCM val = eval (CDR (mx), env);
SCM val = EVAL1 (CDR (mx), env);
if (SCM_VARIABLEP (var))
{
SCM_VARIABLE_SET (var, val);
@ -395,14 +423,14 @@ eval (SCM x, SCM env)
case SCM_M_MODULE_SET:
if (SCM_VARIABLEP (CDR (mx)))
{
SCM_VARIABLE_SET (CDR (mx), eval (CAR (mx), env));
SCM_VARIABLE_SET (CDR (mx), EVAL1 (CAR (mx), env));
return SCM_UNSPECIFIED;
}
else
{
SCM_VARIABLE_SET
(scm_memoize_variable_access_x (x, SCM_BOOL_F),
eval (CAR (mx), env));
EVAL1 (CAR (mx), env));
return SCM_UNSPECIFIED;
}
@ -414,10 +442,11 @@ eval (SCM x, SCM env)
volatile SCM handler, prompt;
vm = scm_the_vm ();
prompt = scm_c_make_prompt (eval (CAR (mx), env), SCM_VM_DATA (vm)->fp,
prompt = scm_c_make_prompt (EVAL1 (CAR (mx), env),
SCM_VM_DATA (vm)->fp,
SCM_VM_DATA (vm)->sp, SCM_VM_DATA (vm)->ip,
0, -1, scm_i_dynwinds ());
handler = eval (CDDR (mx), env);
handler = EVAL1 (CDDR (mx), env);
scm_i_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ()));
if (SCM_PROMPT_SETJMP (prompt))
@ -885,7 +914,7 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
}
for (; i < nreq + nopt; i++, inits = CDR (inits))
env = scm_cons (eval (CAR (inits), env), env);
env = scm_cons (EVAL1 (CAR (inits), env), env);
if (scm_is_true (rest))
env = scm_cons (args, env);
@ -903,7 +932,7 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
env = scm_cons (CAR (args), env);
for (; i < nreq + nopt; i++, inits = CDR (inits))
env = scm_cons (eval (CAR (inits), env), env);
env = scm_cons (EVAL1 (CAR (inits), env), env);
if (scm_is_true (rest))
{
@ -957,7 +986,7 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
{
SCM tail = scm_list_tail (env, SCM_I_MAKINUM (i));
if (SCM_UNBNDP (CAR (tail)))
SCM_SETCAR (tail, eval (CAR (inits), CDR (tail)));
SCM_SETCAR (tail, EVAL1 (CAR (inits), CDR (tail)));
}
}
}
@ -978,7 +1007,8 @@ prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
&& !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
{
for (; scm_is_pair (exps); exps = CDR (exps), nreq--)
new_env = scm_cons (eval (CAR (exps), *inout_env), new_env);
new_env = scm_cons (EVAL1 (CAR (exps), *inout_env),
new_env);
if (SCM_UNLIKELY (nreq != 0))
scm_wrong_num_args (proc);
*out_body = BOOT_CLOSURE_BODY (proc);
@ -989,11 +1019,12 @@ prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
if (SCM_UNLIKELY (argc < nreq))
scm_wrong_num_args (proc);
for (; nreq; nreq--, exps = CDR (exps))
new_env = scm_cons (eval (CAR (exps), *inout_env), new_env);
new_env = scm_cons (EVAL1 (CAR (exps), *inout_env),
new_env);
{
SCM rest = SCM_EOL;
for (; scm_is_pair (exps); exps = CDR (exps))
rest = scm_cons (eval (CAR (exps), *inout_env), rest);
rest = scm_cons (EVAL1 (CAR (exps), *inout_env), rest);
new_env = scm_cons (scm_reverse (rest),
new_env);
}
@ -1004,7 +1035,7 @@ prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
{
SCM args = SCM_EOL;
for (; scm_is_pair (exps); exps = CDR (exps))
args = scm_cons (eval (CAR (exps), *inout_env), args);
args = scm_cons (EVAL1 (CAR (exps), *inout_env), args);
args = scm_reverse_x (args, SCM_UNDEFINED);
prepare_boot_closure_env_for_apply (proc, args, out_body, inout_env);
}

37
libguile/gc.c
View file

@ -208,6 +208,9 @@ run_before_gc_c_hook (void)
/* GC Statistics Keeping
*/
unsigned long scm_gc_ports_collected = 0;
static long gc_time_taken = 0;
static long gc_start_time = 0;
static unsigned long protected_obj_count = 0;
@ -284,7 +287,7 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
gc_times = GC_gc_no;
answer =
scm_list_n (scm_cons (sym_gc_time_taken, SCM_INUM0),
scm_list_n (scm_cons (sym_gc_time_taken, scm_from_long (gc_time_taken)),
scm_cons (sym_heap_size, scm_from_size_t (heap_size)),
scm_cons (sym_heap_free_size, scm_from_size_t (free_bytes)),
scm_cons (sym_heap_total_allocated,
@ -708,6 +711,36 @@ queue_after_gc_hook (void * hook_data SCM_UNUSED,
return NULL;
}
static void *
start_gc_timer (void * hook_data SCM_UNUSED,
void *fn_data SCM_UNUSED,
void *data SCM_UNUSED)
{
if (!gc_start_time)
gc_start_time = scm_c_get_internal_run_time ();
return NULL;
}
static void *
accumulate_gc_timer (void * hook_data SCM_UNUSED,
void *fn_data SCM_UNUSED,
void *data SCM_UNUSED)
{
if (gc_start_time)
{ long now = scm_c_get_internal_run_time ();
gc_time_taken += now - gc_start_time;
gc_start_time = 0;
}
return NULL;
}
char const *
scm_i_tag_name (scm_t_bits tag)
{
@ -803,6 +836,8 @@ scm_init_gc ()
SCM_BOOL_F);
scm_c_hook_add (&scm_before_gc_c_hook, queue_after_gc_hook, NULL, 0);
scm_c_hook_add (&scm_before_gc_c_hook, start_gc_timer, NULL, 0);
scm_c_hook_add (&scm_after_gc_c_hook, accumulate_gc_timer, NULL, 0);
#ifdef HAVE_GC_SET_START_CALLBACK
GC_set_start_callback (run_before_gc_c_hook);

9
libguile/gen-scmconfig.c
View file

@ -123,7 +123,6 @@
#include <stdio.h>
#include <string.h>
#include <uniconv.h>
#define pf printf
@ -397,11 +396,11 @@ main (int argc, char *argv[])
pf ("\n");
pf ("/* Constants from uniconv.h. */\n");
pf ("#define SCM_ICONVEH_ERROR %d\n", (int) iconveh_error);
pf ("#define SCM_ICONVEH_QUESTION_MARK %d\n",
(int) iconveh_question_mark);
pf ("#define SCM_ICONVEH_ERROR %d\n", SCM_I_GSC_ICONVEH_ERROR);
pf ("#define SCM_ICONVEH_QUESTION_MARK %d\n",
SCM_I_GSC_ICONVEH_QUESTION_MARK);
pf ("#define SCM_ICONVEH_ESCAPE_SEQUENCE %d\n",
(int) iconveh_escape_sequence);
SCM_I_GSC_ICONVEH_ESCAPE_SEQUENCE);
printf ("#endif\n");

3
libguile/gen-scmconfig.h.in
View file

@ -31,6 +31,9 @@
#define SCM_I_GSC_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER @SCM_I_GSC_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER@
#define SCM_I_GSC_HAVE_THREAD_STORAGE_CLASS @SCM_I_GSC_HAVE_THREAD_STORAGE_CLASS@
#define SCM_I_GSC_HAVE_STRUCT_DIRENT64 @SCM_I_GSC_HAVE_STRUCT_DIRENT64@
#define SCM_I_GSC_ICONVEH_ERROR @SCM_I_GSC_ICONVEH_ERROR@
#define SCM_I_GSC_ICONVEH_QUESTION_MARK @SCM_I_GSC_ICONVEH_QUESTION_MARK@
#define SCM_I_GSC_ICONVEH_ESCAPE_SEQUENCE @SCM_I_GSC_ICONVEH_ESCAPE_SEQUENCE@
/*
Local Variables:

73
libguile/goops.c
View file

@ -169,6 +169,8 @@ static SCM class_vm_cont;
static SCM class_bytevector;
static SCM class_uvec;
static SCM vtable_class_map = SCM_BOOL_F;
/* 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
offsets. See `SCM_IN_PCLASS_INDEX' et al. */
@ -189,6 +191,41 @@ static SCM scm_sys_goops_loaded (void);
static SCM scm_make_extended_class_from_symbol (SCM type_name_sym,
int applicablep);
SCM
scm_i_define_class_for_vtable (SCM vtable)
{
SCM class;
if (scm_is_false (vtable_class_map))
vtable_class_map = scm_make_weak_key_hash_table (SCM_UNDEFINED);
if (scm_is_false (scm_struct_vtable_p (vtable)))
abort ();
class = scm_hashq_ref (vtable_class_map, vtable, SCM_BOOL_F);
if (scm_is_false (class))
{
if (SCM_UNPACK (scm_class_class))
{
SCM name = SCM_VTABLE_NAME (vtable);
if (!scm_is_symbol (name))
name = scm_string_to_symbol (scm_nullstr);
class = scm_make_extended_class_from_symbol
(name, SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_APPLICABLE));
}
else
/* `create_struct_classes' will fill this in later. */
class = SCM_BOOL_F;
scm_hashq_set_x (vtable_class_map, vtable, class);
}
return class;
}
/* This function is used for efficient type dispatch. */
SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
(SCM x),
@ -288,26 +325,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
return SCM_CLASS_OF (x);
}
else
{
/* ordinary struct */
SCM handle = scm_struct_create_handle (SCM_STRUCT_VTABLE (x));
if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle))))
return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle));
else
{
SCM class, name;
name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
if (!scm_is_symbol (name))
name = scm_string_to_symbol (scm_nullstr);
class =
scm_make_extended_class_from_symbol (name,
SCM_STRUCT_APPLICABLE_P (x));
SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
return class;
}
}
return scm_i_define_class_for_vtable (SCM_CLASS_OF (x));
default:
if (scm_is_pair (x))
return scm_class_pair;
@ -2628,23 +2646,16 @@ static SCM
make_struct_class (void *closure SCM_UNUSED,
SCM vtable, SCM data, SCM prev SCM_UNUSED)
{
SCM sym = SCM_STRUCT_TABLE_NAME (data);
if (scm_is_true (sym))
{
int applicablep = SCM_CLASS_FLAGS (vtable) & SCM_VTABLE_FLAG_APPLICABLE;
SCM_SET_STRUCT_TABLE_CLASS (data,
scm_make_extended_class_from_symbol (sym, applicablep));
}
scm_remember_upto_here_2 (data, vtable);
if (scm_is_false (data))
scm_i_define_class_for_vtable (vtable);
return SCM_UNSPECIFIED;
}
static void
create_struct_classes (void)
{
scm_internal_hash_fold (make_struct_class, 0, SCM_BOOL_F, scm_struct_table);
scm_internal_hash_fold (make_struct_class, 0, SCM_BOOL_F,
vtable_class_map);
}
/**********************************************************************

4
libguile/goops.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_GOOPS_H
#define SCM_GOOPS_H
/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009 Free Software Foundation, Inc.
/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 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 License
@ -307,6 +307,8 @@ SCM_API SCM scm_apply_generic (SCM gf, SCM args);
*/
SCM_API SCM scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3);
SCM_INTERNAL SCM scm_i_define_class_for_vtable (SCM vtable);
SCM_INTERNAL SCM scm_init_goops_builtins (void);
SCM_INTERNAL void scm_init_goops (void);

78
libguile/hashtab.c
View file

@ -761,21 +761,56 @@ scm_hash_fn_ref (SCM table, SCM obj, SCM dflt,
struct set_weak_cdr_data
{
SCM pair;
SCM new_val;
};
static void*
set_weak_cdr (void *data)
{
struct set_weak_cdr_data *d = data;
if (SCM_NIMP (SCM_WEAK_PAIR_CDR (d->pair)) && !SCM_NIMP (d->new_val))
{
GC_unregister_disappearing_link ((void *) SCM_CDRLOC (d->pair));
SCM_SETCDR (d->pair, d->new_val);
}
else
{
SCM_SETCDR (d->pair, d->new_val);
SCM_I_REGISTER_DISAPPEARING_LINK ((void *) SCM_CDRLOC (d->pair),
SCM2PTR (d->new_val));
}
return NULL;
}
SCM
scm_hash_fn_set_x (SCM table, SCM obj, SCM val,
scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
void *closure)
{
SCM it;
SCM pair;
it = scm_hash_fn_create_handle_x (table, obj, SCM_BOOL_F, hash_fn, assoc_fn, closure);
SCM_SETCDR (it, val);
pair = scm_hash_fn_create_handle_x (table, obj, val,
hash_fn, assoc_fn, closure);
if (SCM_HASHTABLE_WEAK_VALUE_P (table) && SCM_NIMP (val))
/* IT is a weak-cdr pair. Register a disappearing link from IT's
cdr to VAL like `scm_weak_cdr_pair' does. */
SCM_I_REGISTER_DISAPPEARING_LINK ((void *) SCM_CDRLOC (it), SCM2PTR (val));
if (SCM_UNLIKELY (!scm_is_eq (SCM_CDR (pair), val)))
{
if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_VALUE_P (table)))
{
struct set_weak_cdr_data data;
data.pair = pair;
data.new_val = val;
GC_call_with_alloc_lock (set_weak_cdr, &data);
}
else
SCM_SETCDR (pair, val);
}
return val;
}
@ -843,6 +878,9 @@ SCM_DEFINE (scm_hashq_get_handle, "hashq-get-handle", 2, 0, 0,
"Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_get_handle
{
if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
return scm_hash_fn_get_handle (table, key,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
@ -858,6 +896,9 @@ SCM_DEFINE (scm_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0,
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hashq_create_handle_x
{
if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
return scm_hash_fn_create_handle_x (table, key, init,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
@ -924,6 +965,9 @@ SCM_DEFINE (scm_hashv_get_handle, "hashv-get-handle", 2, 0, 0,
"Uses @code{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_get_handle
{
if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
return scm_hash_fn_get_handle (table, key,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
@ -939,6 +983,9 @@ SCM_DEFINE (scm_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0,
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hashv_create_handle_x
{
if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
return scm_hash_fn_create_handle_x (table, key, init,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
@ -1003,6 +1050,9 @@ SCM_DEFINE (scm_hash_get_handle, "hash-get-handle", 2, 0, 0,
"Uses @code{equal?} for equality testing.")
#define FUNC_NAME s_scm_hash_get_handle
{
if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
return scm_hash_fn_get_handle (table, key,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
@ -1018,6 +1068,9 @@ SCM_DEFINE (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0,
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hash_create_handle_x
{
if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
return scm_hash_fn_create_handle_x (table, key, init,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
@ -1117,6 +1170,10 @@ SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0,
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
return scm_hash_fn_get_handle (table, key, scm_ihashx, scm_sloppy_assx,
(void *) &closure);
}
@ -1136,6 +1193,10 @@ SCM_DEFINE (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0,
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
return scm_hash_fn_create_handle_x (table, key, init, scm_ihashx,
scm_sloppy_assx, (void *)&closure);
}
@ -1265,6 +1326,9 @@ SCM_DEFINE (scm_hash_for_each_handle, "hash-for-each-handle", 2, 0, 0,
SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, 1, FUNC_NAME);
SCM_VALIDATE_HASHTABLE (2, table);
if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_P (table)))
SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn) scm_call_1,
(void *) SCM_UNPACK (proc),
table);

18
libguile/objprop.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996, 2000, 2001, 2003, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996, 2000, 2001, 2003, 2006, 2008, 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 License
@ -59,11 +59,8 @@ SCM_DEFINE (scm_set_object_properties_x, "set-object-properties!", 2, 0, 0,
"Set @var{obj}'s property list to @var{alist}.")
#define FUNC_NAME s_scm_set_object_properties_x
{
SCM handle;
scm_i_pthread_mutex_lock (&whash_mutex);
handle = scm_hashq_create_handle_x (object_whash, obj, alist);
SCM_SETCDR (handle, alist);
scm_hashq_set_x (object_whash, obj, alist);
scm_i_pthread_mutex_unlock (&whash_mutex);
return alist;
@ -87,19 +84,16 @@ SCM_DEFINE (scm_set_object_property_x, "set-object-property!", 3, 0, 0,
"to @var{value}.")
#define FUNC_NAME s_scm_set_object_property_x
{
SCM h;
SCM alist;
SCM assoc;
scm_i_pthread_mutex_lock (&whash_mutex);
h = scm_hashq_create_handle_x (object_whash, obj, SCM_EOL);
assoc = scm_assq (key, SCM_CDR (h));
alist = scm_hashq_ref (object_whash, obj, SCM_EOL);
assoc = scm_assq (key, alist);
if (SCM_NIMP (assoc))
SCM_SETCDR (assoc, value);
else
{
assoc = scm_acons (key, value, SCM_CDR (h));
SCM_SETCDR (h, assoc);
}
scm_hashq_set_x (object_whash, obj, scm_acons (key, value, alist));
scm_i_pthread_mutex_unlock (&whash_mutex);
return value;

68
libguile/read.c
View file

@ -442,14 +442,14 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
exit:
if (SCM_RECORD_POSITIONS_P)
scm_whash_insert (scm_source_whash,
ans,
scm_make_srcprops (line, column,
SCM_FILENAME (port),
SCM_COPY_SOURCE_P
? ans2
: SCM_UNDEFINED,
SCM_EOL));
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));
return ans;
}
#undef FUNC_NAME
@ -805,15 +805,15 @@ scm_read_quote (int chr, SCM port)
p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
if (SCM_RECORD_POSITIONS_P)
scm_whash_insert (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_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));
return p;
@ -864,15 +864,15 @@ scm_read_syntax (int chr, SCM port)
p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
if (SCM_RECORD_POSITIONS_P)
scm_whash_insert (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_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));
return p;
@ -1561,7 +1561,7 @@ recsexpr (SCM obj, long line, int column, SCM filename)
/* 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_whash_lookup (scm_source_whash, obj)))
if (scm_is_false (scm_hashq_ref (scm_source_whash, obj, SCM_BOOL_F)))
{
if (SCM_COPY_SOURCE_P)
{
@ -1585,13 +1585,13 @@ recsexpr (SCM obj, long line, int column, SCM filename)
recsexpr (SCM_CAR (tmp), line, column, filename);
copy = SCM_UNDEFINED;
}
scm_whash_insert (scm_source_whash,
obj,
scm_make_srcprops (line,
column,
filename,
copy,
SCM_EOL));
scm_hashq_set_x (scm_source_whash,
obj,
scm_make_srcprops (line,
column,
filename,
copy,
SCM_EOL));
}
return obj;
}

38
libguile/srcprop.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2006, 2008, 2009, 2010 Free Software Foundation
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2006, 2008, 2009, 2010, 2011 Free Software Foundation
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -180,10 +180,8 @@ SCM_DEFINE (scm_set_source_properties_x, "set-source-properties!", 2, 0, 0,
"list for @var{obj}.")
#define FUNC_NAME s_scm_set_source_properties_x
{
SCM handle;
SCM_VALIDATE_NIM (1, obj);
handle = scm_hashq_create_handle_x (scm_source_whash, obj, alist);
SCM_SETCDR (handle, alist);
scm_hashq_set_x (scm_source_whash, obj, alist);
return alist;
}
#undef FUNC_NAME
@ -222,49 +220,43 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0,
"@var{key} to @var{datum}. Normally, the key will be a symbol.")
#define FUNC_NAME s_scm_set_source_property_x
{
scm_whash_handle h;
SCM p;
SCM_VALIDATE_NIM (1, obj);
h = scm_whash_get_handle (scm_source_whash, obj);
if (SCM_WHASHFOUNDP (h))
p = SCM_WHASHREF (scm_source_whash, h);
else
{
h = scm_whash_create_handle (scm_source_whash, obj);
p = SCM_EOL;
}
p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
if (scm_is_eq (scm_sym_line, key))
{
if (SRCPROPSP (p))
SETSRCPROPLINE (p, scm_to_int (datum));
else
SCM_WHASHSET (scm_source_whash, h,
scm_make_srcprops (scm_to_int (datum), 0,
SCM_UNDEFINED, SCM_UNDEFINED, p));
scm_hashq_set_x (scm_source_whash, obj,
scm_make_srcprops (scm_to_int (datum), 0,
SCM_UNDEFINED, SCM_UNDEFINED, p));
}
else if (scm_is_eq (scm_sym_column, key))
{
if (SRCPROPSP (p))
SETSRCPROPCOL (p, scm_to_int (datum));
else
SCM_WHASHSET (scm_source_whash, h,
scm_make_srcprops (0, scm_to_int (datum),
SCM_UNDEFINED, SCM_UNDEFINED, p));
scm_hashq_set_x (scm_source_whash, obj,
scm_make_srcprops (0, scm_to_int (datum),
SCM_UNDEFINED, SCM_UNDEFINED, p));
}
else if (scm_is_eq (scm_sym_copy, key))
{
if (SRCPROPSP (p))
SETSRCPROPCOPY (p, datum);
else
SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p));
scm_hashq_set_x (scm_source_whash, obj,
scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p));
}
else
{
if (SRCPROPSP (p))
SETSRCPROPALIST (p, scm_acons (key, datum, SRCPROPALIST (p)));
else
SCM_WHASHSET (scm_source_whash, h, scm_acons (key, datum, p));
scm_hashq_set_x (scm_source_whash, obj,
scm_acons (key, datum, p));
}
return SCM_UNSPECIFIED;
}
@ -281,9 +273,9 @@ SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0,
SCM p, z;
z = scm_cons (x, y);
/* Copy source properties possibly associated with xorig. */
p = scm_whash_lookup (scm_source_whash, xorig);
p = scm_hashq_ref (scm_source_whash, xorig, SCM_BOOL_F);
if (scm_is_true (p))
scm_whash_insert (scm_source_whash, z, p);
scm_hashq_set_x (scm_source_whash, z, p);
return z;
}
#undef FUNC_NAME

26
libguile/srcprop.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_SRCPROP_H
#define SCM_SRCPROP_H
/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 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 License
@ -27,30 +27,6 @@
/* {The old whash table interface}
* *fixme* This is a temporary solution until weak hash table access
* has been optimized for speed (which is quite necessary, if they are
* used for recording of source code positions...)
*/
#define scm_whash_handle SCM
#define scm_whash_get_handle(whash, key) \
scm_hashq_get_handle ((whash), (key))
#define SCM_WHASHFOUNDP(h) (scm_is_true (h))
#define SCM_WHASHREF(whash, handle) SCM_CDR (handle)
#define SCM_WHASHSET(whash, handle, obj) SCM_SETCDR (handle, obj)
#define scm_whash_create_handle(whash, key) \
scm_hashq_create_handle_x ((whash), (key), SCM_UNSPECIFIED)
#define scm_whash_lookup(whash, obj) \
scm_hashq_ref ((whash), (obj), SCM_BOOL_F)
#define scm_whash_insert(whash, key, obj) \
do { \
register SCM w = (whash); \
SCM_WHASHSET (w, scm_whash_create_handle (w, key), obj); \
} while (0)
/* {Source properties}
*/
#define SCM_PROCTRACEP(x) (scm_is_true (scm_procedure_property (x, scm_sym_trace)))

37
libguile/srfi-1.c
View file

@ -956,43 +956,6 @@ scm_srfi1_for_each (SCM proc, SCM arg1, SCM args)
#undef FUNC_NAME
SCM_DEFINE (scm_srfi1_member, "member", 2, 1, 0,
(SCM x, SCM lst, SCM pred),
"Return the first sublist of @var{lst} whose @sc{car} is equal\n"
"to @var{x}. If @var{x} does not appear in @var{lst}, return\n"
"@code{#f}.\n"
"\n"
"Equality is determined by @code{equal?}, or by the equality\n"
"predicate @var{=} if given. @var{=} is called @code{(= @var{x}\n"
"elem)}, ie.@: with the given @var{x} first, so for example to\n"
"find the first element greater than 5,\n"
"\n"
"@example\n"
"(member 5 '(3 5 1 7 2 9) <) @result{} (7 2 9)\n"
"@end example\n"
"\n"
"This version of @code{member} extends the core @code{member} by\n"
"accepting an equality predicate.")
#define FUNC_NAME s_scm_srfi1_member
{
scm_t_trampoline_2 equal_p;
SCM_VALIDATE_LIST (2, lst);
if (SCM_UNBNDP (pred))
equal_p = equal_trampoline;
else
{
SCM_VALIDATE_PROC (SCM_ARG3, pred);
equal_p = scm_call_2;
}
for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
{
if (scm_is_true (equal_p (pred, x, SCM_CAR (lst))))
return lst;
}
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_DEFINE (scm_srfi1_assoc, "assoc", 2, 1, 0,
(SCM key, SCM alist, SCM pred),
"Behaves like @code{assq} but uses third argument @var{pred?}\n"

3
libguile/srfi-1.h
View file

@ -1,6 +1,6 @@
/* srfi-1.h --- SRFI-1 procedures for Guile
*
* Copyright (C) 2002, 2003, 2005, 2006, 2010 Free Software Foundation, Inc.
* Copyright (C) 2002, 2003, 2005, 2006, 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 License
@ -41,7 +41,6 @@ SCM_INTERNAL SCM scm_srfi1_lset_difference_x (SCM equal, SCM lst, SCM rest);
SCM_INTERNAL SCM scm_srfi1_list_copy (SCM lst);
SCM_INTERNAL SCM scm_srfi1_map (SCM proc, SCM arg1, SCM args);
SCM_INTERNAL SCM scm_srfi1_for_each (SCM proc, SCM arg1, SCM args);
SCM_INTERNAL SCM scm_srfi1_member (SCM obj, SCM ls, SCM pred);
SCM_INTERNAL SCM scm_srfi1_assoc (SCM key, SCM alist, SCM pred);
SCM_INTERNAL SCM scm_srfi1_partition (SCM pred, SCM list);
SCM_INTERNAL SCM scm_srfi1_partition_x (SCM pred, SCM list);

246
libguile/stime.c
View file

@ -64,9 +64,13 @@
#endif
# ifdef HAVE_SYS_TYPES_H
# include <sys/types.h>
# endif
#ifdef HAVE_CLOCK_GETTIME
# include <time.h>
#endif
#ifdef HAVE_SYS_TYPES_H
# include <sys/types.h>
#endif
#ifdef HAVE_STRING_H
#include <string.h>
@ -98,27 +102,98 @@ extern char *strptime ();
#endif
#ifdef HAVE_TIMES
static
timet mytime()
#if SCM_SIZEOF_LONG >= 8 && defined HAVE_CLOCK_GETTIME
/* Nanoseconds on 64-bit systems with POSIX timers. */
#define TIME_UNITS_PER_SECOND 1000000000
#else
/* Milliseconds for everyone else. */
#define TIME_UNITS_PER_SECOND 1000
#endif
long scm_c_time_units_per_second = TIME_UNITS_PER_SECOND;
static long
time_from_seconds_and_nanoseconds (long s, long ns)
{
return s * TIME_UNITS_PER_SECOND
+ ns / (1000000000 / TIME_UNITS_PER_SECOND);
}
/* A runtime-selectable mechanism to choose a timing mechanism. Really
we want to use POSIX timers, but that's not always possible. Notably,
the user may have everything she needs at compile-time, but if she's
running on an SMP machine without a common clock source, she can't
use POSIX CPUTIME clocks. */
static long (*get_internal_real_time) (void);
static long (*get_internal_run_time) (void);
#ifdef HAVE_CLOCK_GETTIME
struct timespec posix_real_time_base;
static long
get_internal_real_time_posix_timer (void)
{
struct timespec ts;
clock_gettime (CLOCK_REALTIME, &ts);
return time_from_seconds_and_nanoseconds
(ts.tv_sec - posix_real_time_base.tv_sec,
ts.tv_nsec - posix_real_time_base.tv_nsec);
}
#ifdef _POSIX_CPUTIME
struct timespec posix_run_time_base;
static long
get_internal_run_time_posix_timer (void)
{
struct timespec ts;
clock_gettime (CLOCK_PROCESS_CPUTIME_ID, &ts);
return time_from_seconds_and_nanoseconds
(ts.tv_sec - posix_run_time_base.tv_sec,
ts.tv_nsec - posix_run_time_base.tv_nsec);
}
#endif /* _POSIX_CPUTIME */
#endif /* HAVE_CLOCKTIME */
#ifdef HAVE_GETTIMEOFDAY
struct timeval gettimeofday_real_time_base;
static long
get_internal_real_time_gettimeofday (void)
{
struct timeval tv;
gettimeofday (&tv, NULL);
return time_from_seconds_and_nanoseconds
(tv.tv_sec - gettimeofday_real_time_base.tv_sec,
(tv.tv_usec - gettimeofday_real_time_base.tv_usec) * 1000);
}
#endif
#if defined HAVE_TIMES
static long ticks_per_second;
static long
get_internal_run_time_times (void)
{
struct tms time_buffer;
times(&time_buffer);
return time_buffer.tms_utime + time_buffer.tms_stime;
return (time_buffer.tms_utime + time_buffer.tms_stime)
* TIME_UNITS_PER_SECOND / ticks_per_second;
}
#else
# ifdef LACK_CLOCK
# define mytime() ((time((timet*)0) - scm_your_base) * SCM_TIME_UNITS_PER_SECOND)
# else
# define mytime clock
# endif
#endif
#ifdef HAVE_FTIME
struct timeb scm_your_base = {0};
#else
timet scm_your_base = 0;
#endif
static timet fallback_real_time_base;
static long
get_internal_real_time_fallback (void)
{
return time_from_seconds_and_nanoseconds
((long) time (NULL) - fallback_real_time_base, 0);
}
SCM_DEFINE (scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0,
(),
@ -126,23 +201,7 @@ SCM_DEFINE (scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0,
"started.")
#define FUNC_NAME s_scm_get_internal_real_time
{
#ifdef HAVE_FTIME
struct timeb time_buffer;
SCM tmp;
ftime (&time_buffer);
time_buffer.time -= scm_your_base.time;
tmp = scm_from_long (time_buffer.millitm - scm_your_base.millitm);
tmp = scm_sum (tmp,
scm_product (scm_from_int (1000),
scm_from_int (time_buffer.time)));
return scm_quotient (scm_product (tmp,
scm_from_int (SCM_TIME_UNITS_PER_SECOND)),
scm_from_int (1000));
#else
return scm_from_long ((time((timet*)0) - scm_your_base)
* (int)SCM_TIME_UNITS_PER_SECOND);
#endif /* HAVE_FTIME */
return scm_from_long (get_internal_real_time ());
}
#undef FUNC_NAME
@ -175,27 +234,35 @@ SCM_DEFINE (scm_times, "times", 0, 0, 0,
{
struct tms t;
clock_t rv;
SCM factor;
SCM result = scm_c_make_vector (5, SCM_UNDEFINED);
rv = times (&t);
if (rv == -1)
SCM_SYSERROR;
SCM_SIMPLE_VECTOR_SET (result, 0, scm_from_long (rv));
SCM_SIMPLE_VECTOR_SET (result, 1, scm_from_long (t.tms_utime));
SCM_SIMPLE_VECTOR_SET (result, 2, scm_from_long (t.tms_stime));
SCM_SIMPLE_VECTOR_SET (result ,3, scm_from_long (t.tms_cutime));
SCM_SIMPLE_VECTOR_SET (result, 4, scm_from_long (t.tms_cstime));
factor = scm_quotient (scm_from_long (TIME_UNITS_PER_SECOND),
scm_from_long (ticks_per_second));
SCM_SIMPLE_VECTOR_SET (result, 0,
scm_product (scm_from_long (rv), factor));
SCM_SIMPLE_VECTOR_SET (result, 1,
scm_product (scm_from_long (t.tms_utime), factor));
SCM_SIMPLE_VECTOR_SET (result, 2,
scm_product (scm_from_long (t.tms_stime), factor));
SCM_SIMPLE_VECTOR_SET (result ,3,
scm_product (scm_from_long (t.tms_cutime), factor));
SCM_SIMPLE_VECTOR_SET (result, 4,
scm_product (scm_from_long (t.tms_cstime), factor));
return result;
}
#undef FUNC_NAME
#endif /* HAVE_TIMES */
static long scm_my_base = 0;
long
scm_c_get_internal_run_time ()
scm_c_get_internal_run_time (void)
{
return mytime () - scm_my_base;
return get_internal_run_time ();
}
SCM_DEFINE (scm_get_internal_run_time, "get-internal-run-time", 0, 0, 0,
@ -243,41 +310,18 @@ SCM_DEFINE (scm_gettimeofday, "gettimeofday", 0, 0, 0,
{
#ifdef HAVE_GETTIMEOFDAY
struct timeval time;
int ret, err;
SCM_CRITICAL_SECTION_START;
ret = gettimeofday (&time, NULL);
err = errno;
SCM_CRITICAL_SECTION_END;
if (ret == -1)
{
errno = err;
SCM_SYSERROR;
}
if (gettimeofday (&time, NULL))
SCM_SYSERROR;
return scm_cons (scm_from_long (time.tv_sec),
scm_from_long (time.tv_usec));
#else
# ifdef HAVE_FTIME
struct timeb time;
ftime(&time);
return scm_cons (scm_from_long (time.time),
scm_from_int (time.millitm * 1000));
# else
timet timv;
int err;
SCM_CRITICAL_SECTION_START;
timv = time (NULL);
err = errno;
SCM_CRITICAL_SECTION_END;
if (timv == -1)
{
errno = err;
SCM_SYSERROR;
}
return scm_cons (scm_from_long (timv), scm_from_int (0));
# endif
timet t = time (NULL);
if (errno)
SCM_SYSERROR;
else
return scm_cons (scm_from_long ((long)t), SCM_INUM0);
#endif
}
#undef FUNC_NAME
@ -798,13 +842,55 @@ scm_init_stime()
scm_c_define ("internal-time-units-per-second",
scm_from_long (SCM_TIME_UNITS_PER_SECOND));
#ifdef HAVE_FTIME
if (!scm_your_base.time) ftime(&scm_your_base);
#else
if (!scm_your_base) time(&scm_your_base);
/* Init POSIX timers, and see if we can use them. */
#ifdef HAVE_CLOCK_GETTIME
if (clock_gettime (CLOCK_REALTIME, &posix_real_time_base) == 0)
get_internal_real_time = get_internal_real_time_posix_timer;
#ifdef _POSIX_CPUTIME
{
clockid_t dummy;
/* Only use the _POSIX_CPUTIME clock if it's going to work across
CPUs. */
if (clock_getcpuclockid (0, &dummy) == 0 &&
clock_gettime (CLOCK_PROCESS_CPUTIME_ID, &posix_run_time_base) == 0)
get_internal_run_time = get_internal_run_time_posix_timer;
else
errno = 0;
}
#endif /* _POSIX_CPUTIME */
#endif /* HAVE_CLOCKTIME */
/* If needed, init and use gettimeofday timer. */
#ifdef HAVE_GETTIMEOFDAY
if (!get_internal_real_time
&& gettimeofday (&gettimeofday_real_time_base, NULL) == 0)
get_internal_real_time = get_internal_real_time_gettimeofday;
#endif
if (!scm_my_base) scm_my_base = mytime();
/* Init ticks_per_second for scm_times, and use times(2)-based
run-time timer if needed. */
#ifdef HAVE_TIMES
#ifdef _SC_CLK_TCK
ticks_per_second = sysconf (_SC_CLK_TCK);
#else
ticks_per_second = CLK_TCK;
#endif
if (!get_internal_run_time)
get_internal_run_time = get_internal_run_time_times;
#endif
if (!get_internal_real_time)
/* No POSIX timers, gettimeofday doesn't work... badness! */
{
fallback_real_time_base = time (NULL);
get_internal_real_time = get_internal_real_time_fallback;
}
/* If we don't have a run-time timer, use real-time. */
if (!get_internal_run_time)
get_internal_run_time = get_internal_real_time;
scm_add_feature ("current-time");
#include "libguile/stime.x"

28
libguile/stime.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_STIME_H
#define SCM_STIME_H
/* Copyright (C) 1995,1996,1997,1998,2000, 2003, 2006, 2008 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,1998,2000, 2003, 2006, 2008, 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 License
@ -25,32 +25,10 @@
#include "libguile/__scm.h"
#include <unistd.h> /* for sysconf */
/* This should be figured out by autoconf.
sysconf(_SC_CLK_TCK) is best, since it's the actual running kernel, not
some compile-time CLK_TCK. On glibc 2.3.2 CLK_TCK (when defined) is in
fact sysconf(_SC_CLK_TCK) anyway.
CLK_TCK is obsolete in POSIX. In glibc 2.3.2 it's defined by default,
but if you define _GNU_SOURCE or _POSIX_C_SOURCE to get other features
then it goes away. */
#if ! defined(SCM_TIME_UNITS_PER_SECOND) && defined(_SC_CLK_TCK)
# define SCM_TIME_UNITS_PER_SECOND ((int) sysconf (_SC_CLK_TCK))
#endif
#if ! defined(SCM_TIME_UNITS_PER_SECOND) && defined(CLK_TCK)
# define SCM_TIME_UNITS_PER_SECOND ((int) CLK_TCK)
#endif
#if ! defined(SCM_TIME_UNITS_PER_SECOND) && defined(CLOCKS_PER_SEC)
# define SCM_TIME_UNITS_PER_SECOND ((int) CLOCKS_PER_SEC)
#endif
#if ! defined(SCM_TIME_UNITS_PER_SECOND)
# define SCM_TIME_UNITS_PER_SECOND 60
#endif
SCM_API long scm_c_time_units_per_second;
#define SCM_TIME_UNITS_PER_SECOND scm_c_time_units_per_second
SCM_API long scm_c_get_internal_run_time (void);

26
libguile/struct.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 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 License
@ -54,7 +54,6 @@
static SCM required_vtable_fields = SCM_BOOL_F;
static SCM required_applicable_fields = SCM_BOOL_F;
static SCM required_applicable_with_setter_fields = SCM_BOOL_F;
SCM scm_struct_table = SCM_BOOL_F;
SCM scm_applicable_struct_vtable_vtable;
SCM scm_applicable_struct_with_setter_vtable_vtable;
SCM scm_standard_vtable_vtable;
@ -946,27 +945,13 @@ scm_struct_ihashq (SCM obj, unsigned long n, void *closure)
return SCM_UNPACK (obj) % n;
}
SCM
scm_struct_create_handle (SCM obj)
{
SCM handle = scm_hash_fn_create_handle_x (scm_struct_table,
obj,
SCM_BOOL_F,
scm_struct_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
0);
if (scm_is_false (SCM_CDR (handle)))
SCM_SETCDR (handle, scm_cons (SCM_BOOL_F, SCM_BOOL_F));
return handle;
}
SCM_DEFINE (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0,
(SCM vtable),
"Return the name of the vtable @var{vtable}.")
#define FUNC_NAME s_scm_struct_vtable_name
{
SCM_VALIDATE_VTABLE (1, vtable);
return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)));
return SCM_VTABLE_NAME (vtable);
}
#undef FUNC_NAME
@ -977,8 +962,10 @@ SCM_DEFINE (scm_set_struct_vtable_name_x, "set-struct-vtable-name!", 2, 0, 0,
{
SCM_VALIDATE_VTABLE (1, vtable);
SCM_VALIDATE_SYMBOL (2, name);
SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)),
name);
SCM_SET_VTABLE_NAME (vtable, name);
/* FIXME: remove this, and implement proper struct classes instead.
(Vtables *are* classes.) */
scm_i_define_class_for_vtable (vtable);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@ -1047,7 +1034,6 @@ scm_init_struct ()
OBJ once OBJ has undergone class redefinition. */
GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits));
scm_struct_table = scm_make_weak_key_hash_table (scm_from_int (31));
required_vtable_fields = scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT);
required_applicable_fields = scm_from_locale_string (SCM_APPLICABLE_BASE_LAYOUT);
required_applicable_with_setter_fields = scm_from_locale_string (SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT);

9
libguile/struct.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_STRUCT_H
#define SCM_STRUCT_H
/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 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 License
@ -165,12 +165,6 @@ typedef void (*scm_t_struct_finalize) (SCM obj);
#define SCM_STRUCT_SETTER(X) (SCM_STRUCT_SLOT_REF (X, scm_applicable_struct_index_setter))
#define SCM_SET_STRUCT_SETTER(X,P) (SCM_STRUCT_SLOT_SET (X, scm_applicable_struct_index_setter, P))
#define SCM_STRUCT_TABLE_NAME(X) SCM_CAR (X)
#define SCM_SET_STRUCT_TABLE_NAME(X, NAME) SCM_SETCAR (X, NAME)
#define SCM_STRUCT_TABLE_CLASS(X) SCM_CDR (X)
#define SCM_SET_STRUCT_TABLE_CLASS(X, CLASS) SCM_SETCDR (X, CLASS)
SCM_API SCM scm_struct_table;
SCM_API SCM scm_standard_vtable_vtable;
SCM_API SCM scm_applicable_struct_vtable_vtable;
SCM_API SCM scm_applicable_struct_with_setter_vtable_vtable;
@ -191,7 +185,6 @@ SCM_API SCM scm_struct_ref (SCM handle, SCM pos);
SCM_API SCM scm_struct_set_x (SCM handle, SCM pos, SCM val);
SCM_API SCM scm_struct_vtable (SCM handle);
SCM_API SCM scm_struct_vtable_tag (SCM handle);
SCM_API SCM scm_struct_create_handle (SCM obj);
SCM_API SCM scm_struct_vtable_name (SCM vtable);
SCM_API SCM scm_set_struct_vtable_name_x (SCM vtable, SCM name);
SCM_API void scm_print_struct (SCM exp, SCM port, scm_print_state *);

47
libguile/vm-engine.c
View file

@ -20,12 +20,14 @@
#if (VM_ENGINE == SCM_VM_REGULAR_ENGINE)
#define VM_USE_HOOKS 0 /* Various hooks */
#define VM_CHECK_OBJECT 1 /* Check object table */
#define VM_CHECK_FREE_VARIABLES 1 /* Check free variable access */
#define VM_CHECK_OBJECT 0 /* Check object table */
#define VM_CHECK_FREE_VARIABLES 0 /* Check free variable access */
#define VM_CHECK_UNDERFLOW 0 /* Check underflow when popping values */
#elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
#define VM_USE_HOOKS 1
#define VM_CHECK_OBJECT 1
#define VM_CHECK_FREE_VARIABLES 1
#define VM_CHECK_OBJECT 0
#define VM_CHECK_FREE_VARIABLES 0
#define VM_CHECK_UNDERFLOW 0 /* Check underflow when popping values */
#else
#error unknown debug engine VM_ENGINE
#endif
@ -45,7 +47,9 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
/* Cache variables */
struct scm_objcode *bp = NULL; /* program base pointer */
SCM *objects = NULL; /* constant objects */
#if VM_CHECK_OBJECT
size_t object_count = 0; /* length of OBJECTS */
#endif
SCM *stack_limit = vp->stack_limit; /* stack limit address */
SCM dynstate = SCM_I_CURRENT_THREAD->dynamic_state;
@ -134,21 +138,21 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
/* FIXME: need to sync regs before allocating anything, in each case. */
vm_error_bad_instruction:
err_msg = scm_from_locale_string ("VM: Bad instruction: ~s");
err_msg = scm_from_latin1_string ("VM: Bad instruction: ~s");
finish_args = scm_list_1 (scm_from_uchar (ip[-1]));
goto vm_error;
vm_error_unbound:
/* FINISH_ARGS should be the name of the unbound variable. */
SYNC_ALL ();
err_msg = scm_from_locale_string ("Unbound variable: ~s");
err_msg = scm_from_latin1_string ("Unbound variable: ~s");
scm_error_scm (scm_misc_error_key, program, err_msg,
scm_list_1 (finish_args), SCM_BOOL_F);
goto vm_error;
vm_error_unbound_fluid:
SYNC_ALL ();
err_msg = scm_from_locale_string ("Unbound fluid: ~s");
err_msg = scm_from_latin1_string ("Unbound fluid: ~s");
scm_error_scm (scm_misc_error_key, program, err_msg,
scm_list_1 (finish_args), SCM_BOOL_F);
goto vm_error;
@ -167,26 +171,26 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
vm_error_kwargs_length_not_even:
SYNC_ALL ();
err_msg = scm_from_locale_string ("Odd length of keyword argument list");
err_msg = scm_from_latin1_string ("Odd length of keyword argument list");
scm_error_scm (sym_keyword_argument_error, program, err_msg,
SCM_EOL, SCM_BOOL_F);
vm_error_kwargs_invalid_keyword:
/* FIXME say which one it was */
SYNC_ALL ();
err_msg = scm_from_locale_string ("Invalid keyword");
err_msg = scm_from_latin1_string ("Invalid keyword");
scm_error_scm (sym_keyword_argument_error, program, err_msg,
SCM_EOL, SCM_BOOL_F);
vm_error_kwargs_unrecognized_keyword:
/* FIXME say which one it was */
SYNC_ALL ();
err_msg = scm_from_locale_string ("Unrecognized keyword");
err_msg = scm_from_latin1_string ("Unrecognized keyword");
scm_error_scm (sym_keyword_argument_error, program, err_msg,
SCM_EOL, SCM_BOOL_F);
vm_error_too_many_args:
err_msg = scm_from_locale_string ("VM: Too many arguments");
err_msg = scm_from_latin1_string ("VM: Too many arguments");
finish_args = scm_list_1 (scm_from_int (nargs));
goto vm_error;
@ -204,7 +208,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
goto vm_error;
vm_error_stack_overflow:
err_msg = scm_from_locale_string ("VM: Stack overflow");
err_msg = scm_from_latin1_string ("VM: Stack overflow");
finish_args = SCM_EOL;
if (stack_limit < vp->stack_base + vp->stack_size)
/* There are VM_STACK_RESERVE_SIZE bytes left. Make them available so
@ -213,12 +217,12 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
goto vm_error;
vm_error_stack_underflow:
err_msg = scm_from_locale_string ("VM: Stack underflow");
err_msg = scm_from_latin1_string ("VM: Stack underflow");
finish_args = SCM_EOL;
goto vm_error;
vm_error_improper_list:
err_msg = scm_from_locale_string ("Expected a proper list, but got object with tail ~s");
err_msg = scm_from_latin1_string ("Expected a proper list, but got object with tail ~s");
goto vm_error;
vm_error_not_a_pair:
@ -246,41 +250,41 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
goto vm_error;
vm_error_no_values:
err_msg = scm_from_locale_string ("Zero values returned to single-valued continuation");
err_msg = scm_from_latin1_string ("Zero values returned to single-valued continuation");
finish_args = SCM_EOL;
goto vm_error;
vm_error_not_enough_values:
err_msg = scm_from_locale_string ("Too few values returned to continuation");
err_msg = scm_from_latin1_string ("Too few values returned to continuation");
finish_args = SCM_EOL;
goto vm_error;
vm_error_continuation_not_rewindable:
err_msg = scm_from_locale_string ("Unrewindable partial continuation");
err_msg = scm_from_latin1_string ("Unrewindable partial continuation");
finish_args = scm_cons (finish_args, SCM_EOL);
goto vm_error;
vm_error_bad_wide_string_length:
err_msg = scm_from_locale_string ("VM: Bad wide string length: ~S");
err_msg = scm_from_latin1_string ("VM: Bad wide string length: ~S");
goto vm_error;
#ifdef VM_CHECK_IP
vm_error_invalid_address:
err_msg = scm_from_locale_string ("VM: Invalid program address");
err_msg = scm_from_latin1_string ("VM: Invalid program address");
finish_args = SCM_EOL;
goto vm_error;
#endif
#if VM_CHECK_OBJECT
vm_error_object:
err_msg = scm_from_locale_string ("VM: Invalid object table access");
err_msg = scm_from_latin1_string ("VM: Invalid object table access");
finish_args = SCM_EOL;
goto vm_error;
#endif
#if VM_CHECK_FREE_VARIABLES
vm_error_free_variable:
err_msg = scm_from_locale_string ("VM: Invalid free variable access");
err_msg = scm_from_latin1_string ("VM: Invalid free variable access");
finish_args = SCM_EOL;
goto vm_error;
#endif
@ -298,6 +302,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
#undef VM_USE_HOOKS
#undef VM_CHECK_OBJECT
#undef VM_CHECK_FREE_VARIABLE
#undef VM_CHECK_UNDERFLOW
/*
Local Variables:

26
libguile/vm-engine.h
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
/* Copyright (C) 2001, 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 License
@ -144,6 +144,12 @@
#define ASSERT_BOUND(x)
#endif
#if VM_CHECK_OBJECT
#define SET_OBJECT_COUNT(n) object_count = n
#else
#define SET_OBJECT_COUNT(n) /* nop */
#endif
/* Cache the object table and free variables. */
#define CACHE_PROGRAM() \
{ \
@ -152,10 +158,10 @@
ASSERT_ALIGNED_PROCEDURE (); \
if (SCM_I_IS_VECTOR (SCM_PROGRAM_OBJTABLE (program))) { \
objects = SCM_I_VECTOR_WELTS (SCM_PROGRAM_OBJTABLE (program)); \
object_count = SCM_I_VECTOR_LENGTH (SCM_PROGRAM_OBJTABLE (program)); \
SET_OBJECT_COUNT (SCM_I_VECTOR_LENGTH (SCM_PROGRAM_OBJTABLE (program))); \
} else { \
objects = NULL; \
object_count = 0; \
SET_OBJECT_COUNT (0); \
} \
} \
}
@ -266,18 +272,26 @@
if (SCM_UNLIKELY (sp >= stack_limit)) \
goto vm_error_stack_overflow
#ifdef VM_CHECK_UNDERFLOW
#define CHECK_UNDERFLOW() \
if (SCM_UNLIKELY (sp <= SCM_FRAME_UPPER_ADDRESS (fp))) \
goto vm_error_stack_underflow;
goto vm_error_stack_underflow
#define PRE_CHECK_UNDERFLOW(N) \
if (SCM_UNLIKELY (sp - N <= SCM_FRAME_UPPER_ADDRESS (fp))) \
goto vm_error_stack_underflow;
goto vm_error_stack_underflow
#else
#define CHECK_UNDERFLOW() /* nop */
#define PRE_CHECK_UNDERFLOW(N) /* nop */
#endif
#define PUSH(x) do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
#define DROP() do { sp--; CHECK_UNDERFLOW (); NULLSTACK (1); } while (0)
#define DROPN(_n) do { sp -= (_n); CHECK_UNDERFLOW (); NULLSTACK (_n); } while (0)
#define POP(x) do { PRE_CHECK_UNDERFLOW (1); x = *sp--; NULLSTACK (1); } while (0)
#define POP2(x,y) do { PRE_CHECK_UNDERFLOW (2); x = *sp--; y = *sp--; NULLSTACK (2); } while (0)
#define POP3(x,y,z) do { PRE_CHECK_UNDERFLOW (3); x = *sp--; y = *sp--; z = *sp--; NULLSTACK (3); } while (0)
/* A fast CONS. This has to be fast since its used, for instance, by
POP_LIST when fetching a function's argument list. Note: `scm_cell' is an

3
libguile/vm-i-loader.c
View file

@ -92,8 +92,7 @@ VM_DEFINE_LOADER (106, load_array, "load-array")
SCM type, shape;
size_t len;
FETCH_LENGTH (len);
POP (shape);
POP (type);
POP2 (shape, type);
SYNC_REGISTER ();
PUSH (scm_from_contiguous_typed_array (type, shape, ip, len));
ip += len;

22
libguile/vm-i-scheme.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
/* Copyright (C) 2001, 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 License
@ -147,8 +147,7 @@ VM_DEFINE_FUNCTION (142, cdr, "cdr", 1)
VM_DEFINE_INSTRUCTION (143, set_car, "set-car!", 0, 2, 0)
{
SCM x, y;
POP (y);
POP (x);
POP2 (y, x);
VM_VALIDATE_CONS (x, "set-car!");
SCM_SETCAR (x, y);
NEXT;
@ -157,8 +156,7 @@ VM_DEFINE_INSTRUCTION (143, set_car, "set-car!", 0, 2, 0)
VM_DEFINE_INSTRUCTION (144, set_cdr, "set-cdr!", 0, 2, 0)
{
SCM x, y;
POP (y);
POP (x);
POP2 (y, x);
VM_VALIDATE_CONS (x, "set-cdr!");
SCM_SETCDR (x, y);
NEXT;
@ -469,7 +467,7 @@ VM_DEFINE_INSTRUCTION (164, vector_set, "vector-set", 0, 3, 0)
{
scm_t_signed_bits i = 0;
SCM vect, idx, val;
POP (val); POP (idx); POP (vect);
POP3 (val, idx, vect);
if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
&& SCM_I_INUMP (idx)
&& ((i = SCM_I_INUM (idx)) >= 0)
@ -645,9 +643,7 @@ VM_DEFINE_INSTRUCTION (173, slot_set, "slot-set", 0, 3, 0)
{
SCM instance, idx, val;
size_t slot;
POP (val);
POP (idx);
POP (instance);
POP3 (val, idx, instance);
slot = SCM_I_INUM (idx);
SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val);
NEXT;
@ -820,7 +816,7 @@ BV_FLOAT_REF (f64, ieee_double, double, 8)
if (scm_is_eq (endianness, scm_i_native_endianness)) \
goto VM_LABEL (bv_##stem##_native_set); \
{ \
SCM bv, idx, val; POP (val); POP (idx); POP (bv); \
SCM bv, idx, val; POP3 (val, idx, bv); \
SYNC_REGISTER (); \
scm_bytevector_##fn_stem##_set_x (bv, idx, val, endianness); \
NEXT; \
@ -852,7 +848,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double)
SCM bv, idx, val; \
scm_t_ ## type *int_ptr; \
\
POP (val); POP (idx); POP (bv); \
POP3 (val, idx, bv); \
VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
i = SCM_I_INUM (idx); \
int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
@ -879,7 +875,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double)
SCM bv, idx, val; \
scm_t_ ## type *int_ptr; \
\
POP (val); POP (idx); POP (bv); \
POP3 (val, idx, bv); \
VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
i = SCM_I_INUM (idx); \
int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
@ -903,7 +899,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double)
SCM bv, idx, val; \
type *float_ptr; \
\
POP (val); POP (idx); POP (bv); \
POP3 (val, idx, bv); \
VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
i = SCM_I_INUM (idx); \
float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \

52
libguile/vm-i-system.c
View file

@ -397,18 +397,20 @@ VM_DEFINE_INSTRUCTION (28, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
VM_DEFINE_INSTRUCTION (29, local_set, "local-set", 1, 1, 0)
{
LOCAL_SET (FETCH (), *sp);
DROP ();
SCM x;
POP (x);
LOCAL_SET (FETCH (), x);
NEXT;
}
VM_DEFINE_INSTRUCTION (30, long_local_set, "long-local-set", 2, 1, 0)
{
SCM x;
unsigned int i = FETCH ();
i <<= 8;
i += FETCH ();
LOCAL_SET (i, *sp);
DROP ();
POP (x);
LOCAL_SET (i, x);
NEXT;
}
@ -479,7 +481,7 @@ VM_DEFINE_INSTRUCTION (33, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
offset -= (offset & (1<<23)) << 1; \
}
#define BR(p) \
#define BR(p) \
{ \
scm_t_int32 offset; \
FETCH_OFFSET (offset); \
@ -487,8 +489,6 @@ VM_DEFINE_INSTRUCTION (33, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
ip += offset; \
if (offset < 0) \
VM_HANDLE_INTERRUPTS; \
NULLSTACK (1); \
DROP (); \
NEXT; \
}
@ -504,34 +504,44 @@ VM_DEFINE_INSTRUCTION (34, br, "br", 3, 0, 0)
VM_DEFINE_INSTRUCTION (35, br_if, "br-if", 3, 0, 0)
{
BR (scm_is_true (*sp));
SCM x;
POP (x);
BR (scm_is_true (x));
}
VM_DEFINE_INSTRUCTION (36, br_if_not, "br-if-not", 3, 0, 0)
{
BR (scm_is_false (*sp));
SCM x;
POP (x);
BR (scm_is_false (x));
}
VM_DEFINE_INSTRUCTION (37, br_if_eq, "br-if-eq", 3, 0, 0)
{
sp--; /* underflow? */
BR (scm_is_eq (sp[0], sp[1]));
SCM x, y;
POP2 (y, x);
BR (scm_is_eq (x, y));
}
VM_DEFINE_INSTRUCTION (38, br_if_not_eq, "br-if-not-eq", 3, 0, 0)
{
sp--; /* underflow? */
BR (!scm_is_eq (sp[0], sp[1]));
SCM x, y;
POP2 (y, x);
BR (!scm_is_eq (x, y));
}
VM_DEFINE_INSTRUCTION (39, br_if_null, "br-if-null", 3, 0, 0)
{
BR (scm_is_null (*sp));
SCM x;
POP (x);
BR (scm_is_null (x));
}
VM_DEFINE_INSTRUCTION (40, br_if_not_null, "br-if-not-null", 3, 0, 0)
{
BR (!scm_is_null (*sp));
SCM x;
POP (x);
BR (!scm_is_null (x));
}
@ -1029,8 +1039,7 @@ VM_DEFINE_INSTRUCTION (58, continuation_call, "continuation-call", 0, -1, 0)
VM_DEFINE_INSTRUCTION (59, partial_cont_call, "partial-cont-call", 0, -1, 0)
{
SCM vmcont, intwinds, prevwinds;
POP (intwinds);
POP (vmcont);
POP2 (intwinds, vmcont);
SYNC_REGISTER ();
if (SCM_UNLIKELY (!SCM_VM_CONT_REWINDABLE_P (vmcont)))
{ finish_args = vmcont;
@ -1512,8 +1521,7 @@ VM_DEFINE_INSTRUCTION (81, fix_closure, "fix-closure", 2, -1, 0)
VM_DEFINE_INSTRUCTION (82, define, "define", 0, 0, 2)
{
SCM sym, val;
POP (sym);
POP (val);
POP2 (sym, val);
SYNC_REGISTER ();
VARIABLE_SET (scm_sym2var (sym, scm_current_module_lookup_closure (),
SCM_BOOL_T),
@ -1578,8 +1586,7 @@ VM_DEFINE_INSTRUCTION (85, prompt, "prompt", 4, 2, 0)
VM_DEFINE_INSTRUCTION (86, wind, "wind", 0, 2, 0)
{
SCM wind, unwind;
POP (unwind);
POP (wind);
POP2 (unwind, wind);
SYNC_REGISTER ();
/* Push wind and unwind procedures onto the dynamic stack. Note that neither
are actually called; the compiler should emit calls to wind and unwind for
@ -1675,8 +1682,7 @@ VM_DEFINE_INSTRUCTION (92, fluid_set, "fluid-set", 0, 2, 0)
size_t num;
SCM val, fluid, fluids;
POP (val);
POP (fluid);
POP2 (val, fluid);
fluids = SCM_I_DYNAMIC_STATE_FLUIDS (dynstate);
if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
|| ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))

2
meta/guile-2.2-uninstalled.pc.in
View file

@ -5,5 +5,5 @@ Name: GNU Guile (uninstalled)
Description: GNU's Ubiquitous Intelligent Language for Extension (uninstalled)
Version: @GUILE_VERSION@
Libs: -L${builddir}/libguile -lguile-@GUILE_EFFECTIVE_VERSION@ @BDW_GC_LIBS@
Libs.private: @LIBGMP@ @LIBLTDL@ @LIBFFI_LIBS@ @GUILE_LIBS@
Libs.private: @LIB_CLOCK_GETTIME@ @LIBGMP@ @LIBLTDL@ @LIBFFI_LIBS@ @GUILE_LIBS@
Cflags: -I${srcdir} -I${builddir} @GUILE_CFLAGS@ @BDW_GC_CFLAGS@

2
meta/guile-2.2.pc.in
View file

@ -15,5 +15,5 @@ Name: GNU Guile
Description: GNU's Ubiquitous Intelligent Language for Extension
Version: @GUILE_VERSION@
Libs: -L${libdir} -lguile-@GUILE_EFFECTIVE_VERSION@ @BDW_GC_LIBS@
Libs.private: @LIBGMP@ @LIBLTDL@ @LIBFFI_LIBS@ @GUILE_LIBS@
Libs.private: @LIB_CLOCK_GETTIME@ @LIBGMP@ @LIBLTDL@ @LIBFFI_LIBS@ @GUILE_LIBS@
Cflags: -I${pkgincludedir}/@GUILE_EFFECTIVE_VERSION@ @GUILE_CFLAGS@ @BDW_GC_CFLAGS@

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

@ -3048,6 +3048,8 @@ module '(ice-9 q) '(make-q q-length))}."
(let* ((internal-name (if (pair? name) (car name) name))
(external-name (if (pair? name) (cdr name) name))
(var (module-ensure-local-variable! m internal-name)))
;; FIXME: use a bit on variables instead of object
;; properties.
(set-object-property! var 'replace #t)
(module-add! public-i external-name var)))
names)))

28
module/ice-9/command-line.scm
View file

@ -197,26 +197,28 @@ If FILE begins with `-' the -s switch is mandatory.
(args (cdr args)))
(cond
((not (string-prefix? "-" arg)) ; foo
;; If we specified the -ds option, do_script points to the
;; cdr of an expression like (load #f) we replace the car
;; (i.e., the #f) with the script name.
(if (pair? do-script)
(set-car! do-script arg))
;; If we specified the -ds option, do-script is the cdr of
;; an expression like (load #f). We replace the car (i.e.,
;; the #f) with the script name.
(set! arg0 arg)
(set! interactive? #f)
(finish args
(cons `(load ,arg) out)))
(if (pair? do-script)
(begin
(set-car! do-script arg0)
(finish args out))
(finish args (cons `(load ,arg0) out))))
((string=? arg "-s") ; foo
(if (null? args)
(error "missing argument to `-s' switch"))
(set! arg0 (car args))
(if (pair? do-script)
(set-car! do-script arg0))
(set! interactive? #f)
(finish (cdr args)
(cons `(load ,arg0) out)))
(if (pair? do-script)
(begin
(set-car! do-script arg0)
(finish (cdr args) out))
(finish (cdr args) (cons `(load ,arg0) out))))
((string=? arg "-c") ; evaluate expr
(if (null? args)
(error "missing argument to `-c' switch"))
@ -245,7 +247,7 @@ If FILE begins with `-' the -s switch is mandatory.
((string=? arg "-x") ; add to %load-extensions
(if (null? args)
(error "missing argument to `-L' switch"))
(error "missing argument to `-x' switch"))
(set! user-extensions (cons (car args) user-extensions))
(parse (cdr args)
out))

36
module/ice-9/poe.scm
View file

@ -1,6 +1,6 @@
;;; installed-scm-file
;;;; Copyright (C) 1996, 2001, 2006 Free Software Foundation, Inc.
;;;; Copyright (C) 1996, 2001, 2006, 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
@ -74,17 +74,19 @@
(funcq-assoc arg-list (cdr alist)))))
(define not-found (list 'not-found))
(define (pure-funcq base-func)
(lambda args
(let ((cached (hashx-get-handle funcq-hash funcq-assoc funcq-memo (cons base-func args))))
(if cached
(let* ((key (cons base-func args))
(cached (hashx-ref funcq-hash funcq-assoc funcq-memo key not-found)))
(if (not (eq? cached not-found))
(begin
(funcq-buffer (car cached))
(cdr cached))
(funcq-buffer key)
cached)
(let ((val (apply base-func args))
(key (cons base-func args)))
(let ((val (apply base-func args)))
(funcq-buffer key)
(hashx-set! funcq-hash funcq-assoc funcq-memo key val)
val)))))
@ -101,22 +103,14 @@
(define funcq-memo (make-hash-table size))
(lambda args
(let ((cached (hashx-get-handle funcq-hash funcq-assoc funcq-memo (cons base-func args))))
(if cached
(let* ((key (cons base-func args))
(cached (hashx-ref funcq-hash funcq-assoc funcq-memo key not-found)))
(if (not (eq? cached not-found))
(begin
(funcq-buffer (car cached))
(cdr cached))
(funcq-buffer key)
cached)
(let ((val (apply base-func args))
(key (cons base-func args)))
(let ((val (apply base-func args)))
(funcq-buffer key)
(hashx-set! funcq-hash funcq-assoc funcq-memo key val)
val)))))

3
module/ice-9/psyntax.scm
View file

@ -770,7 +770,8 @@
(lambda (id w)
(define-syntax first
(syntax-rules ()
((_ e) (call-with-values (lambda () e) (lambda (x . ignore) x)))))
;; Rely on Guile's multiple-values truncation.
((_ e) e)))
(define search
(lambda (sym subst marks)
(if (null? subst)

52
module/ice-9/r4rs.scm
View file

@ -1,7 +1,7 @@
;;;; r4rs.scm --- definitions needed for libguile to be R4RS compliant
;;;; Jim Blandy <jimb@cyclic.com> --- October 1996
;;;; Copyright (C) 1996, 1997, 1998, 2000, 2001, 2006, 2010 Free Software Foundation, Inc.
;;;; Copyright (C) 1996, 1997, 1998, 2000, 2001, 2006, 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
@ -140,14 +140,16 @@ already exist. These procedures call PROC
with one argument: the port obtained by opening the named file for
input or output. If the file cannot be opened, an error is
signalled. If the procedure returns, then the port is closed
automatically and the value yielded by the procedure is returned.
automatically and the values yielded by the procedure are returned.
If the procedure does not return, then the port will not be closed
automatically unless it is possible to prove that the port will
never again be used for a read or write operation."
(let* ((file (open-input-file str))
(ans (proc file)))
(close-input-port file)
ans))
(let ((p (open-input-file str)))
(call-with-values
(lambda () (proc p))
(lambda vals
(close-input-port p)
(apply values vals)))))
(define (call-with-output-file str proc)
"PROC should be a procedure of one argument, and STR should be a
@ -156,14 +158,16 @@ already exists. These procedures call PROC
with one argument: the port obtained by opening the named file for
input or output. If the file cannot be opened, an error is
signalled. If the procedure returns, then the port is closed
automatically and the value yielded by the procedure is returned.
automatically and the values yielded by the procedure are returned.
If the procedure does not return, then the port will not be closed
automatically unless it is possible to prove that the port will
never again be used for a read or write operation."
(let* ((file (open-output-file str))
(ans (proc file)))
(close-output-port file)
ans))
(let ((p (open-output-file str)))
(call-with-values
(lambda () (proc p))
(lambda vals
(close-output-port p)
(apply values vals)))))
(define (with-input-from-port port thunk)
(let* ((swaports (lambda () (set! port (set-current-input-port port)))))
@ -184,13 +188,11 @@ input, an input port connected to it is made
the default value returned by `current-input-port',
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed and the previous
default is restored. Returns the value yielded by THUNK. If an
default is restored. Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
(let* ((nport (open-input-file file))
(ans (with-input-from-port nport thunk)))
(close-port nport)
ans))
(call-with-input-file file
(lambda (p) (with-input-from-port p thunk))))
(define (with-output-to-file file thunk)
"THUNK must be a procedure of no arguments, and FILE must be a
@ -199,13 +201,11 @@ The file is opened for output, an output port connected to it is made
the default value returned by `current-output-port',
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed and the previous
default is restored. Returns the value yielded by THUNK. If an
default is restored. Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
(let* ((nport (open-output-file file))
(ans (with-output-to-port nport thunk)))
(close-port nport)
ans))
(call-with-output-file file
(lambda (p) (with-output-to-port p thunk))))
(define (with-error-to-file file thunk)
"THUNK must be a procedure of no arguments, and FILE must be a
@ -214,13 +214,11 @@ The file is opened for output, an output port connected to it is made
the default value returned by `current-error-port',
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed and the previous
default is restored. Returns the value yielded by THUNK. If an
default is restored. Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
(let* ((nport (open-output-file file))
(ans (with-error-to-port nport thunk)))
(close-port nport)
ans))
(call-with-output-file file
(lambda (p) (with-error-to-port p thunk))))
(define (with-input-from-string string thunk)
"THUNK must be a procedure of no arguments.
@ -228,7 +226,7 @@ The test of STRING is opened for
input, an input port connected to it is made,
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed.
Returns the value yielded by THUNK. If an
Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
(call-with-input-string string

10
module/language/assembly.scm
View file

@ -1,6 +1,6 @@
;;; Guile Virtual Machine Assembly
;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
;; Copyright (C) 2001, 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
@ -37,8 +37,8 @@
(define (byte-length assembly)
(pmatch assembly
(,label (guard (not (pair? label)))
0)
((,inst . _) (guard (>= (instruction-length inst) 0))
(+ 1 (instruction-length inst)))
((load-number ,str)
(+ 1 *len-len* (string-length str)))
((load-string ,str)
@ -51,8 +51,8 @@
(+ 1 *len-len* (bytevector-length bv)))
((load-program ,labels ,len ,meta . ,code)
(+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
((,inst . _) (guard (>= (instruction-length inst) 0))
(+ 1 (instruction-length inst)))
(,label (guard (not (pair? label)))
0)
(else (error "unknown instruction" assembly))))

237
module/language/assembly/compile-bytecode.scm
View file

@ -1,6 +1,6 @@
;;; Guile VM assembler
;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
;; Copyright (C) 2001, 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
@ -22,111 +22,144 @@
#:use-module (system base pmatch)
#:use-module (language assembly)
#:use-module (system vm instruction)
#:use-module (srfi srfi-4)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module ((srfi srfi-26) #:select (cut))
#:export (compile-bytecode))
;; Gross.
(define (port-position port)
(seek port 0 SEEK_CUR))
(define (compile-bytecode assembly env . opts)
(pmatch assembly
((load-program . _)
(call-with-values open-bytevector-output-port
(lambda (port get-bytevector)
;; Don't emit the `load-program' byte.
(write-bytecode assembly port '() 0 #f)
(values (get-bytevector) env env))))
(else (error "bad assembly" assembly))))
(define-syntax define-inline1
(syntax-rules ()
((_ (proc arg) body body* ...)
(define-syntax proc
(syntax-rules ()
((_ (arg-expr (... ...)))
(let ((x (arg-expr (... ...))))
(proc x)))
((_ arg)
(begin body body* ...)))))))
(define (fill-bytecode bv)
(let ((pos 0))
(define-inline1 (write-byte b)
(bytevector-u8-set! bv pos b)
(set! pos (1+ pos)))
(define u32-bv (make-bytevector 4))
(define-inline1 (write-int24-be x)
(bytevector-s32-set! u32-bv 0 x (endianness big))
(bytevector-u8-set! bv pos (bytevector-u8-ref u32-bv 1))
(bytevector-u8-set! bv (+ pos 1) (bytevector-u8-ref u32-bv 2))
(bytevector-u8-set! bv (+ pos 2) (bytevector-u8-ref u32-bv 3))
(set! pos (+ pos 3)))
(define-inline1 (write-uint32-be x)
(bytevector-u32-set! bv pos x (endianness big))
(set! pos (+ pos 4)))
(define-inline1 (write-uint32 x)
(bytevector-u32-native-set! bv pos x)
(set! pos (+ pos 4)))
(define-inline1 (write-loader-len len)
(bytevector-u8-set! bv pos (ash len -16))
(bytevector-u8-set! bv (+ pos 1) (logand (ash len -8) 255))
(bytevector-u8-set! bv (+ pos 2) (logand len 255))
(set! pos (+ pos 3)))
(define-inline1 (write-latin1-string s)
(let ((len (string-length s)))
(write-loader-len len)
(let lp ((i 0))
(if (< i len)
(begin
(bytevector-u8-set! bv (+ pos i)
(char->integer (string-ref s i)))
(lp (1+ i)))))
(set! pos (+ pos len))))
(define-inline1 (write-bytevector bv*)
(let ((len (bytevector-length bv*)))
(write-loader-len len)
(bytevector-copy! bv* 0 bv pos len)
(set! pos (+ pos len))))
(define-inline1 (write-wide-string s)
(write-bytevector (string->utf32 s (native-endianness))))
(define-inline1 (write-break label)
(let ((offset (- (assq-ref labels label) (+ (get-addr) 3))))
(cond ((>= offset (ash 1 23)) (error "jump too far forward" offset))
((< offset (- (ash 1 23))) (error "jump too far backwards" offset))
(else (write-int24-be offset)))))
(define (write-bytecode asm port labels address emit-opcode?)
;; Write ASM's bytecode to PORT, a (binary) output port. If EMIT-OPCODE? is
;; false, don't emit bytecode for the first opcode encountered. Assume code
;; starts at ADDRESS (an integer). LABELS is assumed to be an alist mapping
;; labels to addresses.
(define u32-bv (make-bytevector 4))
(define write-byte (cut put-u8 port <>))
(define get-addr
(let ((start (port-position port)))
(lambda ()
(+ address (- (port-position port) start)))))
(define (write-latin1-string s)
(write-loader-len (string-length s))
(string-for-each (lambda (c) (write-byte (char->integer c))) s))
(define (write-int24-be x)
(bytevector-s32-set! u32-bv 0 x (endianness big))
(put-bytevector port u32-bv 1 3))
(define (write-uint32-be x)
(bytevector-u32-set! u32-bv 0 x (endianness big))
(put-bytevector port u32-bv))
(define (write-uint32 x)
(bytevector-u32-native-set! u32-bv 0 x)
(put-bytevector port u32-bv))
(define (write-wide-string s)
(write-loader-len (* 4 (string-length s)))
(put-bytevector port (string->utf32 s (native-endianness))))
(define (write-loader-len len)
(write-byte (ash len -16))
(write-byte (logand (ash len -8) 255))
(write-byte (logand len 255)))
(define (write-bytevector bv)
(write-loader-len (bytevector-length bv))
(put-bytevector port bv))
(define (write-break label)
(let ((offset (- (assq-ref labels label) (+ (get-addr) 3))))
(cond ((>= offset (ash 1 23)) (error "jump too far forward" offset))
((< offset (- (ash 1 23))) (error "jump too far backwards" offset))
(else (write-int24-be offset)))))
(define (write-bytecode asm labels address emit-opcode?)
;; Write ASM's bytecode to BV. If EMIT-OPCODE? is false, don't
;; emit bytecode for the first opcode encountered. Assume code
;; starts at ADDRESS (an integer). LABELS is assumed to be an
;; alist mapping labels to addresses.
(define get-addr
(let ((start pos))
(lambda ()
(+ address (- pos start)))))
(define (write-break label)
(let ((offset (- (assq-ref labels label) (+ (get-addr) 3))))
(cond ((>= offset (ash 1 23)) (error "jump too far forward" offset))
((< offset (- (ash 1 23))) (error "jump too far backwards" offset))
(else (write-int24-be offset)))))
(let ((inst (car asm))
(args (cdr asm)))
(let ((opcode (instruction->opcode inst))
(len (instruction-length inst)))
(if emit-opcode?
(write-byte opcode))
(pmatch asm
((load-program ,labels ,length ,meta . ,code)
(write-uint32 length)
(write-uint32 (if meta (1- (byte-length meta)) 0))
(fold (lambda (asm address)
(let ((start (port-position port)))
(write-bytecode asm port labels address #t)
(+ address (- (port-position port) start))))
0
code)
(if meta
;; Don't emit the `load-program' byte for metadata. Note that
;; META's bytecode meets the alignment requirements of
;; `scm_objcode', thanks to the alignment computed in `(language
;; assembly)'.
(write-bytecode meta port '() 0 #f)))
((make-char32 ,x) (write-uint32-be x))
((load-number ,str) (write-latin1-string str))
((load-string ,str) (write-latin1-string str))
((load-wide-string ,str) (write-wide-string str))
((load-symbol ,str) (write-latin1-string str))
((load-array ,bv) (write-bytevector bv))
((br ,l) (write-break l))
((br-if ,l) (write-break l))
((br-if-not ,l) (write-break l))
((br-if-eq ,l) (write-break l))
((br-if-not-eq ,l) (write-break l))
((br-if-null ,l) (write-break l))
((br-if-not-null ,l) (write-break l))
((br-if-nargs-ne ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
((br-if-nargs-lt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
((br-if-nargs-gt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
((mv-call ,n ,l) (write-byte n) (write-break l))
((prompt ,escape-only? ,l) (write-byte escape-only?) (write-break l))
(else
(cond
((< (instruction-length inst) 0)
(error "unhanded variable-length instruction" asm))
((not (= (length args) len))
(error "bad number of args to instruction" asm len))
(else
(for-each write-byte args))))))))
(let ((inst (car asm))
(args (cdr asm)))
(let ((opcode (instruction->opcode inst))
(len (instruction-length inst)))
(if emit-opcode?
(write-byte opcode))
(pmatch asm
((load-program ,labels ,length ,meta . ,code)
(write-uint32 length)
(write-uint32 (if meta (1- (byte-length meta)) 0))
(fold (lambda (asm address)
(let ((start pos))
(write-bytecode asm labels address #t)
(+ address (- pos start))))
0
code)
(if meta
;; Don't emit the `load-program' byte for metadata. Note that
;; META's bytecode meets the alignment requirements of
;; `scm_objcode', thanks to the alignment computed in `(language
;; assembly)'.
(write-bytecode meta '() 0 #f)))
((make-char32 ,x) (write-uint32-be x))
((load-number ,str) (write-latin1-string str))
((load-string ,str) (write-latin1-string str))
((load-wide-string ,str) (write-wide-string str))
((load-symbol ,str) (write-latin1-string str))
((load-array ,bv) (write-bytevector bv))
((br ,l) (write-break l))
((br-if ,l) (write-break l))
((br-if-not ,l) (write-break l))
((br-if-eq ,l) (write-break l))
((br-if-not-eq ,l) (write-break l))
((br-if-null ,l) (write-break l))
((br-if-not-null ,l) (write-break l))
((br-if-nargs-ne ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
((br-if-nargs-lt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
((br-if-nargs-gt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
((mv-call ,n ,l) (write-byte n) (write-break l))
((prompt ,escape-only? ,l) (write-byte escape-only?) (write-break l))
(else
(cond
((< len 0)
(error "unhanded variable-length instruction" asm))
((not (= (length args) len))
(error "bad number of args to instruction" asm len))
(else
(for-each (lambda (x) (write-byte x)) args))))))))
;; Don't emit the `load-program' byte.
(write-bytecode assembly '() 0 #f)
(if (= pos (bytevector-length bv))
(values bv env env)
(error "failed to fill bytevector" bv pos
(bytevector-length bv)))))
(pmatch assembly
((load-program ,labels ,length ,meta . ,code)
(fill-bytecode (make-bytevector (+ 4 4 length
(if meta
(1- (byte-length meta))
0)))))
(else (error "bad assembly" assembly))))

75
module/srfi/srfi-1.scm
View file

@ -1,6 +1,6 @@
;;; srfi-1.scm --- List Library
;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010 Free Software Foundation, Inc.
;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 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
@ -16,6 +16,11 @@
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Some parts from the reference implementation, which is
;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
;;; this code as long as you do not remove this copyright notice or
;;; hold me liable for its use.
;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
;;; Date: 2001-06-06
@ -747,15 +752,23 @@ and those making the associations."
(define* (alist-delete! key alist #:optional (k= equal?))
(alist-delete key alist k=)) ; XXX:optimize
;;; Delete / assoc / member
(define* (member x ls #:optional (= equal?))
(cond
((eq? = eq?) (memq x ls))
((eq? = eqv?) (memv x ls))
(else (find-tail (lambda (y) (= x y)) ls))))
;;; Set operations on lists
(define (lset<= = . rest)
(if (null? rest)
#t
(let lp ((f (car rest)) (r (cdr rest)))
(or (null? r)
(and (every (lambda (el) (member el (car r) =)) f)
(lp (car r) (cdr r)))))))
#t
(let lp ((f (car rest)) (r (cdr rest)))
(or (null? r)
(and (every (lambda (el) (member el (car r) =)) f)
(lp (car r) (cdr r)))))))
(define (lset= = . rest)
(if (null? rest)
@ -780,25 +793,41 @@ a common tail with LIST), but the order they're added is unspecified.
The given `=' procedure is used for comparing elements, called
as `(@var{=} listelem elem)', i.e., the second argument is one of the
given REST parameters."
(let lp ((l rest) (acc list))
(if (null? l)
acc
(if (member (car l) acc (lambda (x y) (= y x)))
(lp (cdr l) acc)
(lp (cdr l) (cons (car l) acc))))))
;; If `=' is `eq?' or `eqv?', users won't be able to tell which arg is
;; first, so we can pass the raw procedure through to `member',
;; allowing `memq' / `memv' to be selected.
(define pred
(if (or (eq? = eq?) (eq? = eqv?))
=
(lambda (x y) (= y x))))
(let lp ((ans list) (rest rest))
(if (null? rest)
ans
(lp (if (member (car rest) ans pred)
ans
(cons (car rest) ans))
(cdr rest)))))
(define (lset-union = . rest)
(let ((acc '()))
(for-each (lambda (lst)
(if (null? acc)
(set! acc lst)
(for-each (lambda (elem)
(if (not (member elem acc
(lambda (x y) (= y x))))
(set! acc (cons elem acc))))
lst)))
rest)
acc))
;; Likewise, allow memq / memv to be used if possible.
(define pred
(if (or (eq? = eq?) (eq? = eqv?))
=
(lambda (x y) (= y x))))
(fold (lambda (lis ans) ; Compute ANS + LIS.
(cond ((null? lis) ans) ; Don't copy any lists
((null? ans) lis) ; if we don't have to.
((eq? lis ans) ans)
(else
(fold (lambda (elt ans)
(if (member elt ans pred)
ans
(cons elt ans)))
ans lis))))
'()
rest))
(define (lset-intersection = list1 . rest)
(let lp ((l list1) (acc '()))

93
module/statprof.scm
View file

@ -1,7 +1,7 @@
;;;; (statprof) -- a statistical profiler for Guile
;;;; -*-scheme-*-
;;;;
;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
;;;; Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com>
;;;; Copyright (C) 2001 Rob Browning <rlb at defaultvalue dot org>
;;;;
@ -159,7 +159,9 @@
statprof-fetch-call-tree
statprof
with-statprof))
with-statprof
gcprof))
;; This profiler tracks two numbers for every function called while
@ -379,8 +381,8 @@ than @code{statprof-stop}, @code{#f} otherwise."
(accumulate-time (get-internal-run-time))
(set! last-start-time #f))))
(define (statprof-reset sample-seconds sample-microseconds count-calls?
. full-stacks?)
(define* (statprof-reset sample-seconds sample-microseconds count-calls?
#:optional full-stacks?)
"Reset the statprof sampler interval to @var{sample-seconds} and
@var{sample-microseconds}. If @var{count-calls?} is true, arrange to
instrument procedure calls as well as collecting statistical profiling
@ -397,7 +399,7 @@ Enables traps and debugging as necessary."
(set! sampling-frequency (cons sample-seconds sample-microseconds))
(set! remaining-prof-time #f)
(set! procedure-data (make-hash-table 131))
(set! record-full-stacks? (and (pair? full-stacks?) (car full-stacks?)))
(set! record-full-stacks? full-stacks?)
(set! stacks '())
(sigaction SIGPROF profile-signal-handler)
#t)
@ -531,7 +533,7 @@ optional @var{port} argument is passed, uses the current output port."
(simple-format #t "Sample count: ~A\n" (statprof-sample-count))
(simple-format #t "Total time: ~A seconds (~A seconds in GC)\n"
(statprof-accumulated-time)
(/ gc-time-taken internal-time-units-per-second))))))
(/ gc-time-taken 1.0 internal-time-units-per-second))))))
(define (statprof-display-anomolies)
"A sanity check that attempts to detect anomolies in statprof's
@ -701,3 +703,82 @@ default: @code{#f}
#:count-calls? ,(kw-arg-ref #:count-calls? args #f)
#:full-stacks? ,(kw-arg-ref #:full-stacks? args #f)))
(define* (gcprof thunk #:key (loop 1) (full-stacks? #f))
"Do an allocation profile of the execution of @var{thunk}.
The stack will be sampled soon after every garbage collection, yielding
an approximate idea of what is causing allocation in your program.
Since GC does not occur very frequently, you may need to use the
@var{loop} parameter, to cause @var{thunk} to be called @var{loop}
times.
If @var{full-stacks?} is true, at each sample, statprof will store away the
whole call tree, for later analysis. Use @code{statprof-fetch-stacks} or
@code{statprof-fetch-call-tree} to retrieve the last-stored stacks."
(define (reset)
(if (positive? profile-level)
(error "Can't reset profiler while profiler is running."))
(set! accumulated-time 0)
(set! last-start-time #f)
(set! sample-count 0)
(set! %count-calls? #f)
(set! procedure-data (make-hash-table 131))
(set! record-full-stacks? full-stacks?)
(set! stacks '()))
(define (gc-callback)
(cond
(inside-profiler?)
(else
(set! inside-profiler? #t)
;; FIXME: should be able to set an outer frame for the stack cut
(let ((stop-time (get-internal-run-time))
;; Cut down to gc-callback, and then one before (the
;; after-gc async). See the note in profile-signal-handler
;; also.
(stack (or (make-stack #t gc-callback 0 1)
(pk 'what! (make-stack #t)))))
(sample-stack-procs stack)
(accumulate-time stop-time)
(set! last-start-time (get-internal-run-time)))
(set! inside-profiler? #f))))
(define (start)
(set! profile-level (+ profile-level 1))
(if (= profile-level 1)
(begin
(set! remaining-prof-time #f)
(set! last-start-time (get-internal-run-time))
(set! gc-time-taken (cdr (assq 'gc-time-taken (gc-stats))))
(add-hook! after-gc-hook gc-callback)
(set-vm-trace-level! (the-vm) (1+ (vm-trace-level (the-vm))))
#t)))
(define (stop)
(set! profile-level (- profile-level 1))
(if (zero? profile-level)
(begin
(set! gc-time-taken
(- (cdr (assq 'gc-time-taken (gc-stats))) gc-time-taken))
(remove-hook! after-gc-hook gc-callback)
(accumulate-time (get-internal-run-time))
(set! last-start-time #f))))
(dynamic-wind
(lambda ()
(reset)
(start))
(lambda ()
(let lp ((i loop))
(if (not (zero? i))
(begin
(thunk)
(lp (1- i))))))
(lambda ()
(stop)
(statprof-display)
(set! procedure-data #f))))

14
test-suite/tests/asm-to-bytecode.test
View file

@ -19,11 +19,9 @@
#:use-module ((rnrs io ports) #:select (open-bytevector-output-port))
#:use-module (test-suite lib)
#:use-module (system vm instruction)
#:use-module (language assembly)
#:use-module (language assembly compile-bytecode))
(define write-bytecode
(@@ (language assembly compile-bytecode) write-bytecode))
(define (->u8-list sym val)
(let ((entry (assq-ref `((uint16 2 ,bytevector-u16-native-set!)
(uint32 4 ,bytevector-u32-native-set!))
@ -54,11 +52,11 @@
(run-test `(length ,x) #t
(lambda ()
(call-with-values open-bytevector-output-port
(lambda (port get-bytevector)
(write-bytecode x port '() 0 #t)
(set! v (get-bytevector))
(= (bytevector-length v) len)))))
(let* ((wrapped `(load-program () ,(byte-length x) #f ,x))
(bv (compile-bytecode wrapped '())))
(set! v (make-bytevector (- (bytevector-length bv) 8)))
(bytevector-copy! bv 8 v 0 (bytevector-length v))
(= (bytevector-length v) len))))
(run-test `(compile-equal? ,x ,y) #t
(lambda ()
(equal? v y)))))

132
test-suite/tests/ports.test
View file

@ -495,97 +495,95 @@
(syntax-rules ()
((_ port check ...)
(and (make-check port check) ...))))
(make-peek+read-checks
(syntax-rules ()
((_ port (result ...) e1 expected ...)
(make-peek+read-checks port
(result ...
(peek-char -> e1)
(read-char -> e1))
expected ...))
((_ port (result ...))
(make-checks port result ...))
((_ port #f e1 expected ...)
(make-peek+read-checks port
((peek-char -> e1)
(read-char -> e1))
expected ...))))
(test-decoding-error
(syntax-rules (tests)
((_ sequence encoding strategy (tests checks ...))
(pass-if (format #f "test-decoding-error: ~s ~s ~s ~s"
(caar '(checks ...))
'sequence encoding strategy)
(let ((p (open-bytevector-input-port
(u8-list->bytevector 'sequence))))
(set-port-encoding! p encoding)
(set-port-conversion-strategy! p strategy)
(make-checks p checks ...)))))))
(syntax-rules ()
((_ sequence encoding strategy (expected ...))
(begin
(pass-if (format #f "test-decoding-error: ~s ~s ~s"
'sequence encoding strategy)
(let ((p (open-bytevector-input-port
(u8-list->bytevector 'sequence))))
(set-port-encoding! p encoding)
(set-port-conversion-strategy! p strategy)
(make-checks p
(read-char -> expected) ...)))
;; Generate the same test, but with one
;; `peek-char' call before each `read-char'.
;; Both should yield the same result.
(pass-if (format #f "test-decoding-error: ~s ~s ~s + peek-char"
'sequence encoding strategy)
(let ((p (open-bytevector-input-port
(u8-list->bytevector 'sequence))))
(set-port-encoding! p encoding)
(set-port-conversion-strategy! p strategy)
(make-peek+read-checks p #f expected ...))))))))
(test-decoding-error (255 65 66 67) "UTF-8" 'error
(tests
(read-char -> error)
(read-char -> #\A)
(read-char -> #\B)
(read-char -> #\C)
(read-char -> eof)))
(error #\A #\B #\C eof))
(test-decoding-error (255 65 66 67) "UTF-8" 'escape
;; `escape' should behave exactly like `error'.
(tests
(read-char -> error)
(read-char -> #\A)
(read-char -> #\B)
(read-char -> #\C)
(read-char -> eof)))
(error #\A #\B #\C eof))
(test-decoding-error (255 206 187 206 188) "UTF-8" 'substitute
(tests
(read-char -> #\?)
(read-char -> #\λ)
(read-char -> #\μ)
(read-char -> eof)))
(#\? #\λ #\μ eof))
(test-decoding-error (206 187 206) "UTF-8" 'error
;; Unterminated sequence.
(tests
(read-char -> #\λ)
(read-char -> error)
(read-char -> eof)))
(#\λ error eof))
(test-decoding-error (206 187 206) "UTF-8" 'substitute
;; Unterminated sequence.
(tests
(read-char -> #\λ)
(read-char -> #\?)
(read-char -> eof)))
(test-decoding-error (255 65 66 67) "UTF-8" 'error
(tests
;; `peek-char' should repeatedly raise an error.
(peek-char -> error)
(peek-char -> error)
(peek-char -> error)
;; Move past the error.
(read-char -> error)
(read-char -> #\A)
(read-char -> #\B)
(read-char -> #\C)
(read-char -> eof)))
(#\λ #\? eof))
;; Check how ill-formed UTF-8 sequences are handled (see Table 3-7
;; of the "Conformance" chapter of Unicode 6.0.0.)
(test-decoding-error (#xc0 #x80 #x41) "UTF-8" 'error
(tests
(read-char -> error) ;; C0: should be in the C2..DF range
(read-char -> error) ;; 80: invalid
(read-char -> #\A)
(read-char -> eof)))
(error ;; C0: should be in the C2..DF range
error ;; 80: invalid
#\A
eof))
(test-decoding-error (#xc0 #x80 #x41) "UTF-8" 'error
(tests
(read-char -> error) ;; C0: should be in the C2..DF range
(read-char -> error) ;; 80: invalid
(read-char -> #\A)
(read-char -> eof)))
(test-decoding-error (#xc0 #x80 #x41) "UTF-8" 'substitute
(#\? ;; C0: should be in the C2..DF range
#\? ;; 80: invalid
#\A
eof))
(test-decoding-error (#xc2 #x41 #x42) "UTF-8" 'error
(error ;; 41: should be in the 80..BF range
#\B
eof))
(test-decoding-error (#xe0 #x88 #x88) "UTF-8" 'error
(tests
(read-char -> error) ;; 2nd byte should be in the A0..BF range
(read-char -> eof)))
(error ;; 2nd byte should be in the A0..BF range
eof))
(test-decoding-error (#xe0 #xa0 #x41 #x42) "UTF-8" 'error
(error ;; 3rd byte should be in the 80..BF range
#\B
eof))
(test-decoding-error (#xf0 #x88 #x88 #x88) "UTF-8" 'error
(tests
(read-char -> error) ;; 2nd byte should be in the 90..BF range
(read-char -> eof)))))
(error ;; 2nd byte should be in the 90..BF range
eof))))
(with-test-prefix "call-with-output-string"