[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.0.1-47-g891a185
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.0.1-47-g891a185 |
|
Date: |
Thu, 05 May 2011 14:41:48 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=891a1851a1e0e47560cf99cf76e9478d77e1a7db
The branch, master has been updated
via 891a1851a1e0e47560cf99cf76e9478d77e1a7db (commit)
via eae2438d2bd1d9a0e0aaa052abb8b36b2d073850 (commit)
via 9e775af3bf0db457eceb5a9a1f4a87968d011492 (commit)
via 89f9dd7065971d9d9047b42f044c06cc943f5efc (commit)
via 81f529091b4741aea6060194d83d24c17460d652 (commit)
via 2d239a78d49a435ffe879c6e4a32a57d486b231b (commit)
via e640b44046dbb5516e691f1b4c6dd3a4cad3ac5b (commit)
via e6e286bb5895197a9433817fe3998a7c7c525386 (commit)
via 00b6ef23f320afff35fcc3a163bc66d5f9a230e8 (commit)
via 4a42658f6a49d17cd07919bc4632ae3bddae33e5 (commit)
via e3b8bce8f4fb5adf93e42bfa3263f7368ad4a3be (commit)
via 7ff0f239b2534cba823adc351dda8e64db6f4a08 (commit)
via f3c6a02c885ad29f6af0d786e14e34c81d49470f (commit)
via 1d9c2e6271105ee0f728127d9b544432b7cc0f4f (commit)
via 8bee35bc536eebd3d223c23990a65b1341e760ac (commit)
via eceee4efe35fc2c128faf362c71a617585124324 (commit)
via 1ad9fdb727ef4e49f8d624b655cfc38c2f757e22 (commit)
via 4466db75daa6ebee48a889f79046b1f4fb22c75a (commit)
via d1c4720ca382c5588a52108326343eaaab9063ca (commit)
via ecc9d1b547b21830f5ce4f1eaceb6b9dde44e5dc (commit)
via b735d33b2b636f457c8ca0740c99169e20b377b3 (commit)
via f3a9a51d3ea545042f8e62b42a48afadb4839ee9 (commit)
via 501cf7d6074eab3330555c1d57284fbd34e286d8 (commit)
via ad378da9757ebc503a9d6237afbc74dacea1b348 (commit)
via e6efefad0811e975e6a501829a0871d030b0ab88 (commit)
via dac9812a2e02c680693ee6dfeb1a96f2b45151cb (commit)
via 800690141ff7ce91014bfc1134a9bb0e358ce38f (commit)
from 1903eae4c9ab97b575dad4ab1f5cf05436d84ab3 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 891a1851a1e0e47560cf99cf76e9478d77e1a7db
Merge: 1903eae eae2438
Author: Andy Wingo <address@hidden>
Date: Thu May 5 14:09:29 2011 +0200
Merge remote-tracking branch 'origin/stable-2.0'
-----------------------------------------------------------------------
Summary of changes:
acinclude.m4 | 32 ++++
configure.ac | 67 +++++++
doc/ref/api-control.texi | 2 +-
libguile/Makefile.am | 13 +-
libguile/deprecated.c | 113 ++++++++++--
libguile/deprecated.h | 31 +++
libguile/eval.c | 85 ++++++---
libguile/gc.c | 37 ++++-
libguile/gen-scmconfig.c | 9 +-
libguile/gen-scmconfig.h.in | 3 +
libguile/goops.c | 73 +++++---
libguile/goops.h | 4 +-
libguile/hashtab.c | 78 +++++++-
libguile/objprop.c | 18 +--
libguile/read.c | 68 ++++----
libguile/srcprop.c | 38 ++---
libguile/srcprop.h | 26 +---
libguile/srfi-1.c | 37 ----
libguile/srfi-1.h | 3 +-
libguile/stime.c | 244 +++++++++++++++++--------
libguile/stime.h | 28 +---
libguile/struct.c | 26 +--
libguile/struct.h | 9 +-
libguile/vm-engine.c | 47 +++--
libguile/vm-engine.h | 26 ++-
libguile/vm-i-loader.c | 3 +-
libguile/vm-i-scheme.c | 22 +--
libguile/vm-i-system.c | 52 +++---
meta/guile-2.2-uninstalled.pc.in | 2 +-
meta/guile-2.2.pc.in | 2 +-
module/ice-9/boot-9.scm | 2 +
module/ice-9/command-line.scm | 28 ++--
module/ice-9/poe.scm | 36 ++--
module/ice-9/psyntax.scm | 3 +-
module/ice-9/r4rs.scm | 52 +++---
module/language/assembly.scm | 10 +-
module/language/assembly/compile-bytecode.scm | 237 ++++++++++++++----------
module/srfi/srfi-1.scm | 75 ++++++---
module/statprof.scm | 93 +++++++++-
test-suite/tests/asm-to-bytecode.test | 14 +-
test-suite/tests/ports.test | 134 +++++++-------
41 files changed, 1177 insertions(+), 705 deletions(-)
diff --git a/acinclude.m4 b/acinclude.m4
index 0938671..ba8b090 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 8050193..83e1487 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 1dde8ea..4e13527 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 4790cd9..263d6b0 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 @@ address@hidden@_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 4d6027c..41e4dbc 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 7deee35..6693c6c 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 164aadd..f830e00 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 7d2724c..0451fbb 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 5834346..176f25c 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 125720a..30f43d7 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 f610208..2747490 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 06ade43..47a6e4e 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 48660d7..37d168c 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 dfa8494..7b50d71 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 4b6828b..b36c27c 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 003abc5..f9b000c 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 99b8482..5c9ccb9 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 5c07504..f67e600 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 593d9bb..85aa65d 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 78aa673..1c4f407 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 8b70cee..e41f797 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 e5ecc1a..4a2a9d7 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 7a4d635..c3c7d8f 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 4b0ca3e..bfa8489 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 ad226dc..abbc110 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 0d86784..6fa8eb2 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 9e249bc..60e4452 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 71c5281..ea00fc9 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 9cc1aaf..6d8c36b 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 address@hidden@ @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 f76dd01..ecca778 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} address@hidden@ @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 401d904..294b915 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 a34c9a6..e94336a 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 e7b6e3a..c19a760 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 17acf3f..85ceb13 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 4d3feba..86b6e94 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 <address@hidden> --- 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 e119628..ad8dead 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 ae64768..c315829 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 8ddf271..68b62de 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 <address@hidden>
;;; 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 da6f3f1..33246e5 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
address@hidden 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
address@hidden 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 0d8fecb..049e4b2 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 69e028f..7b646a1 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"
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.0.1-47-g891a185,
Andy Wingo <=