summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--acinclude.m432
-rw-r--r--configure.ac67
-rw-r--r--doc/ref/api-control.texi2
-rw-r--r--libguile/Makefile.am13
-rw-r--r--libguile/deprecated.c113
-rw-r--r--libguile/deprecated.h31
-rw-r--r--libguile/eval.c85
-rw-r--r--libguile/gc.c37
-rw-r--r--libguile/gen-scmconfig.c9
-rw-r--r--libguile/gen-scmconfig.h.in3
-rw-r--r--libguile/goops.c73
-rw-r--r--libguile/goops.h4
-rw-r--r--libguile/hashtab.c78
-rw-r--r--libguile/objprop.c18
-rw-r--r--libguile/read.c68
-rw-r--r--libguile/srcprop.c38
-rw-r--r--libguile/srcprop.h26
-rw-r--r--libguile/srfi-1.c37
-rw-r--r--libguile/srfi-1.h3
-rw-r--r--libguile/stime.c244
-rw-r--r--libguile/stime.h28
-rw-r--r--libguile/struct.c26
-rw-r--r--libguile/struct.h9
-rw-r--r--libguile/vm-engine.c47
-rw-r--r--libguile/vm-engine.h26
-rw-r--r--libguile/vm-i-loader.c3
-rw-r--r--libguile/vm-i-scheme.c22
-rw-r--r--libguile/vm-i-system.c52
-rw-r--r--meta/guile-2.2-uninstalled.pc.in2
-rw-r--r--meta/guile-2.2.pc.in2
-rw-r--r--module/ice-9/boot-9.scm2
-rw-r--r--module/ice-9/command-line.scm28
-rw-r--r--module/ice-9/poe.scm36
-rw-r--r--module/ice-9/psyntax.scm3
-rw-r--r--module/ice-9/r4rs.scm52
-rw-r--r--module/language/assembly.scm10
-rw-r--r--module/language/assembly/compile-bytecode.scm237
-rw-r--r--module/srfi/srfi-1.scm75
-rw-r--r--module/statprof.scm93
-rw-r--r--test-suite/tests/asm-to-bytecode.test14
-rw-r--r--test-suite/tests/ports.test134
41 files changed, 1177 insertions, 705 deletions
diff --git a/acinclude.m4 b/acinclude.m4
index 0938671c0..ba8b09031 100644
--- a/acinclude.m4
+++ b/acinclude.m4
@@ -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
+])
diff --git a/configure.ac b/configure.ac
index 8050193fd..83e148733 100644
--- a/configure.ac
+++ b/configure.ac
@@ -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
@@ -1193,6 +1196,70 @@ 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?
#
# Following code comes from Autoconf 2.61's internal _AC_LIBOBJ_ALLOCA
diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi
index 1dde8ea9d..4e13527c1 100644
--- a/doc/ref/api-control.texi
+++ b/doc/ref/api-control.texi
@@ -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}
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 4790cd917..263d6b04c 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -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) \
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index 4d6027c35..41e4dbcd3 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -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"
}
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index 7deee359a..6693c6c73 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -752,6 +752,37 @@ 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);
#endif
diff --git a/libguile/eval.c b/libguile/eval.c
index 164aadd70..f830e0099 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -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);
}
diff --git a/libguile/gc.c b/libguile/gc.c
index 7d2724c5f..0451fbb42 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -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);
diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c
index 5834346c7..176f25c02 100644
--- a/libguile/gen-scmconfig.c
+++ b/libguile/gen-scmconfig.c
@@ -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");
diff --git a/libguile/gen-scmconfig.h.in b/libguile/gen-scmconfig.h.in
index 125720acd..30f43d7b7 100644
--- a/libguile/gen-scmconfig.h.in
+++ b/libguile/gen-scmconfig.h.in
@@ -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:
diff --git a/libguile/goops.c b/libguile/goops.c
index f6102085f..274749048 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -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);
}
/**********************************************************************
diff --git a/libguile/goops.h b/libguile/goops.h
index 06ade43a4..47a6e4eca 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -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);
diff --git a/libguile/hashtab.c b/libguile/hashtab.c
index 48660d75c..37d168cf4 100644
--- a/libguile/hashtab.c
+++ b/libguile/hashtab.c
@@ -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);
diff --git a/libguile/objprop.c b/libguile/objprop.c
index dfa849441..7b50d71d0 100644
--- a/libguile/objprop.c
+++ b/libguile/objprop.c
@@ -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;
diff --git a/libguile/read.c b/libguile/read.c
index 4b6828b8a..b36c27c81 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -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;
}
diff --git a/libguile/srcprop.c b/libguile/srcprop.c
index 003abc56d..f9b000c47 100644
--- a/libguile/srcprop.c
+++ b/libguile/srcprop.c
@@ -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
diff --git a/libguile/srcprop.h b/libguile/srcprop.h
index 99b848244..5c9ccb960 100644
--- a/libguile/srcprop.h
+++ b/libguile/srcprop.h
@@ -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)))
diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index 5c0750451..f67e60082 100644
--- a/libguile/srfi-1.c
+++ b/libguile/srfi-1.c
@@ -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"
diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h
index 593d9bb02..85aa65d0c 100644
--- a/libguile/srfi-1.h
+++ b/libguile/srfi-1.h
@@ -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);
diff --git a/libguile/stime.c b/libguile/stime.c
index 78aa6731a..1c4f407f9 100644
--- a/libguile/stime.c
+++ b/libguile/stime.c
@@ -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);
+ /* 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
+
+ /* 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
- if (!scm_your_base) time(&scm_your_base);
+ 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 (!scm_my_base) scm_my_base = mytime();
+ /* 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"
diff --git a/libguile/stime.h b/libguile/stime.h
index 8b70cee62..e41f79730 100644
--- a/libguile/stime.h
+++ b/libguile/stime.h
@@ -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);
diff --git a/libguile/struct.c b/libguile/struct.c
index e5ecc1aaf..4a2a9d750 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -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);
diff --git a/libguile/struct.h b/libguile/struct.h
index 7a4d63521..c3c7d8f12 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -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 *);
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 4b0ca3ec3..bfa848967 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -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:
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index ad226dc03..abbc11077 100644
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -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
diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c
index 0d8678485..6fa8eb2ea 100644
--- a/libguile/vm-i-loader.c
+++ b/libguile/vm-i-loader.c
@@ -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;
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index 9e249bc85..60e44521e 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -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); \
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 71c5281c8..ea00fc920 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -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)))
diff --git a/meta/guile-2.2-uninstalled.pc.in b/meta/guile-2.2-uninstalled.pc.in
index 9cc1aaf18..6d8c36b18 100644
--- a/meta/guile-2.2-uninstalled.pc.in
+++ b/meta/guile-2.2-uninstalled.pc.in
@@ -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@
diff --git a/meta/guile-2.2.pc.in b/meta/guile-2.2.pc.in
index f76dd0156..ecca778e1 100644
--- a/meta/guile-2.2.pc.in
+++ b/meta/guile-2.2.pc.in
@@ -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@
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 401d90476..294b91515 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -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)))
diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm
index a34c9a67c..e94336a90 100644
--- a/module/ice-9/command-line.scm
+++ b/module/ice-9/command-line.scm
@@ -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))
diff --git a/module/ice-9/poe.scm b/module/ice-9/poe.scm
index e7b6e3a75..c19a760b2 100644
--- a/module/ice-9/poe.scm
+++ b/module/ice-9/poe.scm
@@ -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)))))
-
-
-
-
-
-
-
-
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 17acf3ff9..85ceb13c2 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -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)
diff --git a/module/ice-9/r4rs.scm b/module/ice-9/r4rs.scm
index 4d3febafa..86b6e9454 100644
--- a/module/ice-9/r4rs.scm
+++ b/module/ice-9/r4rs.scm
@@ -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
diff --git a/module/language/assembly.scm b/module/language/assembly.scm
index e119628da..ad8dead65 100644
--- a/module/language/assembly.scm
+++ b/module/language/assembly.scm
@@ -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))))
diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm
index ae6476891..c31582991 100644
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@@ -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))))
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 8ddf2714b..68b62de56 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -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 '()))
diff --git a/module/statprof.scm b/module/statprof.scm
index da6f3f1fc..33246e5bd 100644
--- a/module/statprof.scm
+++ b/module/statprof.scm
@@ -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))))
diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test
index 0d8fecb5a..049e4b2fd 100644
--- a/test-suite/tests/asm-to-bytecode.test
+++ b/test-suite/tests/asm-to-bytecode.test
@@ -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)))))
diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test
index 69e028f36..7b646a110 100644
--- a/test-suite/tests/ports.test
+++ b/test-suite/tests/ports.test
@@ -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)))
-
- (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" '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"