summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-05-05 14:09:29 +0200
committerAndy Wingo <wingo@pobox.com>2011-05-05 14:09:29 +0200
commit891a1851a1e0e47560cf99cf76e9478d77e1a7db (patch)
tree8d00ba1b7f14b75005285d86abba3ea05b4f1767 /libguile
parent1903eae4c9ab97b575dad4ab1f5cf05436d84ab3 (diff)
parenteae2438d2bd1d9a0e0aaa052abb8b36b2d073850 (diff)
downloadguile-891a1851a1e0e47560cf99cf76e9478d77e1a7db.tar.gz
Merge remote-tracking branch 'origin/stable-2.0'
Diffstat (limited to 'libguile')
-rw-r--r--libguile/Makefile.am13
-rw-r--r--libguile/deprecated.c113
-rw-r--r--libguile/deprecated.h31
-rw-r--r--libguile/eval.c85
-rw-r--r--libguile/gc.c37
-rw-r--r--libguile/gen-scmconfig.c9
-rw-r--r--libguile/gen-scmconfig.h.in3
-rw-r--r--libguile/goops.c73
-rw-r--r--libguile/goops.h4
-rw-r--r--libguile/hashtab.c78
-rw-r--r--libguile/objprop.c18
-rw-r--r--libguile/read.c68
-rw-r--r--libguile/srcprop.c38
-rw-r--r--libguile/srcprop.h26
-rw-r--r--libguile/srfi-1.c37
-rw-r--r--libguile/srfi-1.h3
-rw-r--r--libguile/stime.c244
-rw-r--r--libguile/stime.h28
-rw-r--r--libguile/struct.c26
-rw-r--r--libguile/struct.h9
-rw-r--r--libguile/vm-engine.c47
-rw-r--r--libguile/vm-engine.h26
-rw-r--r--libguile/vm-i-loader.c3
-rw-r--r--libguile/vm-i-scheme.c22
-rw-r--r--libguile/vm-i-system.c52
25 files changed, 665 insertions, 428 deletions
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 4790cd917..263d6b04c 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -55,13 +55,11 @@ gen_scmconfig_SOURCES = gen-scmconfig.c
## Override default rule; this should be compiled for BUILD host.
## For some reason, OBJEXT does not include the dot
gen-scmconfig.$(OBJEXT): gen-scmconfig.c
- $(AM_V_GEN) \
- if [ "$(cross_compiling)" = "yes" ]; then \
- $(CC_FOR_BUILD) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) \
- $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) \
- -c -o $@ $<; \
- else \
- $(COMPILE) -c -o $@ $<; \
+ $(AM_V_GEN) \
+ if [ "$(cross_compiling)" = "yes" ]; then \
+ $(CC_FOR_BUILD) $(DEFS) $(DEFAULT_INCLUDES) $(AM_CPPFLAGS) -c -o $@ $<; \
+ else \
+ $(COMPILE) -c -o $@ $<; \
fi
## Override default rule; this should run on BUILD host.
@@ -474,6 +472,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_LDFLAGS = \
$(ISNANF_LIBM) \
$(ISNANL_LIBM) \
$(LDEXP_LIBM) \
+ $(LIB_CLOCK_GETTIME) \
$(LIBSOCKET) \
$(LOG1P_LIBM) \
$(LTLIBICONV) \
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index 4d6027c35..41e4dbcd3 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -2425,17 +2425,17 @@ SCM_DEFINE (scm_primitive_property_ref, "primitive-property-ref", 2, 0, 0,
"property value.")
#define FUNC_NAME s_scm_primitive_property_ref
{
- SCM h;
+ SCM alist;
scm_c_issue_deprecation_warning
("`primitive-property-ref' is deprecated. Use object properties.");
SCM_VALIDATE_CONS (SCM_ARG1, prop);
- h = scm_hashq_get_handle (properties_whash, obj);
- if (scm_is_true (h))
+ alist = scm_hashq_ref (properties_whash, obj, SCM_EOL);
+ if (scm_is_pair (alist))
{
- SCM assoc = scm_assq (prop, SCM_CDR (h));
+ SCM assoc = scm_assq (prop, alist);
if (scm_is_true (assoc))
return SCM_CDR (assoc);
}
@@ -2445,9 +2445,8 @@ SCM_DEFINE (scm_primitive_property_ref, "primitive-property-ref", 2, 0, 0,
else
{
SCM val = scm_call_2 (SCM_CAR (prop), prop, obj);
- if (scm_is_false (h))
- h = scm_hashq_create_handle_x (properties_whash, obj, SCM_EOL);
- SCM_SETCDR (h, scm_acons (prop, val, SCM_CDR (h)));
+ scm_hashq_set_x (properties_whash, obj,
+ scm_acons (prop, val, alist));
return val;
}
}
@@ -2459,21 +2458,19 @@ SCM_DEFINE (scm_primitive_property_set_x, "primitive-property-set!", 3, 0, 0,
"Set the property @var{prop} of @var{obj} to @var{val}.")
#define FUNC_NAME s_scm_primitive_property_set_x
{
- SCM h, assoc;
+ SCM alist, assoc;
scm_c_issue_deprecation_warning
("`primitive-property-set!' is deprecated. Use object properties.");
SCM_VALIDATE_CONS (SCM_ARG1, prop);
- h = scm_hashq_create_handle_x (properties_whash, obj, SCM_EOL);
- assoc = scm_assq (prop, SCM_CDR (h));
- if (SCM_NIMP (assoc))
+ alist = scm_hashq_ref (properties_whash, obj, SCM_EOL);
+ assoc = scm_assq (prop, alist);
+ if (scm_is_pair (assoc))
SCM_SETCDR (assoc, val);
else
- {
- assoc = scm_acons (prop, val, SCM_CDR (h));
- SCM_SETCDR (h, assoc);
- }
+ scm_hashq_set_x (properties_whash, obj,
+ scm_acons (prop, val, alist));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -2484,26 +2481,104 @@ SCM_DEFINE (scm_primitive_property_del_x, "primitive-property-del!", 2, 0, 0,
"Remove any value associated with @var{prop} and @var{obj}.")
#define FUNC_NAME s_scm_primitive_property_del_x
{
- SCM h;
+ SCM alist;
scm_c_issue_deprecation_warning
("`primitive-property-del!' is deprecated. Use object properties.");
SCM_VALIDATE_CONS (SCM_ARG1, prop);
- h = scm_hashq_get_handle (properties_whash, obj);
- if (scm_is_true (h))
- SCM_SETCDR (h, scm_assq_remove_x (SCM_CDR (h), prop));
+ alist = scm_hashq_ref (properties_whash, obj, SCM_EOL);
+ if (scm_is_pair (alist))
+ scm_hashq_set_x (properties_whash, obj, scm_assq_remove_x (alist, prop));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
+SCM
+scm_whash_get_handle (SCM whash, SCM key)
+{
+ scm_c_issue_deprecation_warning
+ ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
+
+ return scm_hashq_get_handle (whash, key);
+}
+
+int
+SCM_WHASHFOUNDP (SCM h)
+{
+ scm_c_issue_deprecation_warning
+ ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
+
+ return scm_is_true (h);
+}
+
+SCM
+SCM_WHASHREF (SCM whash, SCM handle)
+{
+ scm_c_issue_deprecation_warning
+ ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
+
+ return SCM_CDR (handle);
+}
+
+void
+SCM_WHASHSET (SCM whash, SCM handle, SCM obj)
+{
+ scm_c_issue_deprecation_warning
+ ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
+
+ SCM_SETCDR (handle, obj);
+}
+
+SCM
+scm_whash_create_handle (SCM whash, SCM key)
+{
+ scm_c_issue_deprecation_warning
+ ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
+
+ return scm_hashq_create_handle_x (whash, key, SCM_UNSPECIFIED);
+}
+
+SCM
+scm_whash_lookup (SCM whash, SCM obj)
+{
+ scm_c_issue_deprecation_warning
+ ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
+
+ return scm_hashq_ref (whash, obj, SCM_BOOL_F);
+}
+
+void
+scm_whash_insert (SCM whash, SCM key, SCM obj)
+{
+ scm_c_issue_deprecation_warning
+ ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
+
+ scm_hashq_set_x (whash, key, obj);
+}
+
+
+
+SCM scm_struct_table = SCM_BOOL_F;
+
+SCM
+scm_struct_create_handle (SCM obj)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_struct_create_handle' is deprecated, and has no effect.");
+
+ return scm_cons (obj, scm_cons (SCM_BOOL_F, SCM_BOOL_F));
+}
+
+
void
scm_i_init_deprecated ()
{
properties_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+ scm_struct_table = scm_make_hash_table (SCM_UNDEFINED);
#include "libguile/deprecated.x"
}
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index 7deee359a..6693c6c73 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -752,6 +752,37 @@ SCM_DEPRECATED SCM scm_primitive_property_del_x (SCM prop, SCM obj);
+/* {The old whash table interface}
+ * Deprecated, as the hash table interface is sufficient, and accessing
+ * handles of weak hash tables is no longer supported.
+ */
+
+#define scm_whash_handle SCM
+
+SCM_DEPRECATED SCM scm_whash_get_handle (SCM whash, SCM key);
+SCM_DEPRECATED int SCM_WHASHFOUNDP (SCM h);
+SCM_DEPRECATED SCM SCM_WHASHREF (SCM whash, SCM handle);
+SCM_DEPRECATED void SCM_WHASHSET (SCM whash, SCM handle, SCM obj);
+SCM_DEPRECATED SCM scm_whash_create_handle (SCM whash, SCM key);
+SCM_DEPRECATED SCM scm_whash_lookup (SCM whash, SCM obj);
+SCM_DEPRECATED void scm_whash_insert (SCM whash, SCM key, SCM obj);
+
+
+
+
+/* No need for a table for names, and the struct->class mapping is
+ maintained by GOOPS now. */
+#define SCM_STRUCT_TABLE_NAME(X) SCM_CAR (X)
+#define SCM_SET_STRUCT_TABLE_NAME(X, NAME) SCM_SETCAR (X, NAME)
+#define SCM_STRUCT_TABLE_CLASS(X) SCM_CDR (X)
+#define SCM_SET_STRUCT_TABLE_CLASS(X, CLASS) SCM_SETCDR (X, CLASS)
+
+SCM_DEPRECATED SCM scm_struct_table;
+SCM_DEPRECATED SCM scm_struct_create_handle (SCM obj);
+
+
+
+
void scm_i_init_deprecated (void);
#endif
diff --git a/libguile/eval.c b/libguile/eval.c
index 164aadd70..f830e0099 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -175,6 +175,32 @@ static void error_unrecognized_keyword (SCM proc)
}
+/* Multiple values truncation. */
+static SCM
+truncate_values (SCM x)
+{
+ if (SCM_LIKELY (!SCM_VALUESP (x)))
+ return x;
+ else
+ {
+ SCM l = scm_struct_ref (x, SCM_INUM0);
+ if (SCM_LIKELY (scm_is_pair (l)))
+ return scm_car (l);
+ else
+ {
+ scm_ithrow (scm_from_latin1_symbol ("vm-run"),
+ scm_list_3 (scm_from_latin1_symbol ("vm-run"),
+ scm_from_locale_string
+ ("Too few values returned to continuation"),
+ SCM_EOL),
+ 1);
+ /* Not reached. */
+ return SCM_BOOL_F;
+ }
+ }
+}
+#define EVAL1(x, env) (truncate_values (eval ((x), (env))))
+
/* the environment:
(VAL ... . MOD)
If MOD is #f, it means the environment was captured before modules were
@@ -209,7 +235,7 @@ eval (SCM x, SCM env)
goto loop;
case SCM_M_IF:
- if (scm_is_true (eval (CAR (mx), env)))
+ if (scm_is_true (EVAL1 (CAR (mx), env)))
x = CADR (mx);
else
x = CDDR (mx);
@@ -220,7 +246,8 @@ eval (SCM x, SCM env)
SCM inits = CAR (mx);
SCM new_env = CAPTURE_ENV (env);
for (; scm_is_pair (inits); inits = CDR (inits))
- new_env = scm_cons (eval (CAR (inits), env), new_env);
+ new_env = scm_cons (EVAL1 (CAR (inits), env),
+ new_env);
env = new_env;
x = CDR (mx);
goto loop;
@@ -233,14 +260,14 @@ eval (SCM x, SCM env)
return mx;
case SCM_M_DEFINE:
- scm_define (CAR (mx), eval (CDR (mx), env));
+ scm_define (CAR (mx), EVAL1 (CDR (mx), env));
return SCM_UNSPECIFIED;
case SCM_M_DYNWIND:
{
SCM in, out, res, old_winds;
- in = eval (CAR (mx), env);
- out = eval (CDDR (mx), env);
+ in = EVAL1 (CAR (mx), env);
+ out = EVAL1 (CDDR (mx), env);
scm_call_0 (in);
old_winds = scm_i_dynwinds ();
scm_i_set_dynwinds (scm_acons (in, out, old_winds));
@@ -257,10 +284,10 @@ eval (SCM x, SCM env)
len = scm_ilength (CAR (mx));
fluidv = alloca (sizeof (SCM)*len);
for (i = 0, walk = CAR (mx); i < len; i++, walk = CDR (walk))
- fluidv[i] = eval (CAR (walk), env);
+ fluidv[i] = EVAL1 (CAR (walk), env);
valuesv = alloca (sizeof (SCM)*len);
for (i = 0, walk = CADR (mx); i < len; i++, walk = CDR (walk))
- valuesv[i] = eval (CAR (walk), env);
+ valuesv[i] = EVAL1 (CAR (walk), env);
wf = scm_i_make_with_fluids (len, fluidv, valuesv);
scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
@@ -274,9 +301,9 @@ eval (SCM x, SCM env)
case SCM_M_APPLY:
/* Evaluate the procedure to be applied. */
- proc = eval (CAR (mx), env);
+ proc = EVAL1 (CAR (mx), env);
/* Evaluate the argument holding the list of arguments */
- args = eval (CADR (mx), env);
+ args = EVAL1 (CADR (mx), env);
apply_proc:
/* Go here to tail-apply a procedure. PROC is the procedure and
@@ -291,7 +318,7 @@ eval (SCM x, SCM env)
case SCM_M_CALL:
/* Evaluate the procedure to be applied. */
- proc = eval (CAR (mx), env);
+ proc = EVAL1 (CAR (mx), env);
argc = SCM_I_INUM (CADR (mx));
mx = CDDR (mx);
@@ -307,21 +334,22 @@ eval (SCM x, SCM env)
argv = alloca (argc * sizeof (SCM));
for (i = 0; i < argc; i++, mx = CDR (mx))
- argv[i] = eval (CAR (mx), env);
+ argv[i] = EVAL1 (CAR (mx), env);
return scm_c_vm_run (scm_the_vm (), proc, argv, argc);
}
case SCM_M_CONT:
- return scm_i_call_with_current_continuation (eval (mx, env));
+ return scm_i_call_with_current_continuation (EVAL1 (mx, env));
case SCM_M_CALL_WITH_VALUES:
{
SCM producer;
SCM v;
- producer = eval (CAR (mx), env);
- proc = eval (CDR (mx), env); /* proc is the consumer. */
+ producer = EVAL1 (CAR (mx), env);
+ /* `proc' is the consumer. */
+ proc = EVAL1 (CDR (mx), env);
v = scm_call_with_vm (scm_the_vm (), producer, SCM_EOL);
if (SCM_VALUESP (v))
args = scm_struct_ref (v, SCM_INUM0);
@@ -347,7 +375,7 @@ eval (SCM x, SCM env)
case SCM_M_LEXICAL_SET:
{
int n;
- SCM val = eval (CDR (mx), env);
+ SCM val = EVAL1 (CDR (mx), env);
for (n = SCM_I_INUM (CAR (mx)); n; n--)
env = CDR (env);
SCM_SETCAR (env, val);
@@ -368,7 +396,7 @@ eval (SCM x, SCM env)
case SCM_M_TOPLEVEL_SET:
{
SCM var = CAR (mx);
- SCM val = eval (CDR (mx), env);
+ SCM val = EVAL1 (CDR (mx), env);
if (SCM_VARIABLEP (var))
{
SCM_VARIABLE_SET (var, val);
@@ -395,14 +423,14 @@ eval (SCM x, SCM env)
case SCM_M_MODULE_SET:
if (SCM_VARIABLEP (CDR (mx)))
{
- SCM_VARIABLE_SET (CDR (mx), eval (CAR (mx), env));
+ SCM_VARIABLE_SET (CDR (mx), EVAL1 (CAR (mx), env));
return SCM_UNSPECIFIED;
}
else
{
SCM_VARIABLE_SET
(scm_memoize_variable_access_x (x, SCM_BOOL_F),
- eval (CAR (mx), env));
+ EVAL1 (CAR (mx), env));
return SCM_UNSPECIFIED;
}
@@ -414,10 +442,11 @@ eval (SCM x, SCM env)
volatile SCM handler, prompt;
vm = scm_the_vm ();
- prompt = scm_c_make_prompt (eval (CAR (mx), env), SCM_VM_DATA (vm)->fp,
+ prompt = scm_c_make_prompt (EVAL1 (CAR (mx), env),
+ SCM_VM_DATA (vm)->fp,
SCM_VM_DATA (vm)->sp, SCM_VM_DATA (vm)->ip,
0, -1, scm_i_dynwinds ());
- handler = eval (CDDR (mx), env);
+ handler = EVAL1 (CDDR (mx), env);
scm_i_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ()));
if (SCM_PROMPT_SETJMP (prompt))
@@ -885,7 +914,7 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
}
for (; i < nreq + nopt; i++, inits = CDR (inits))
- env = scm_cons (eval (CAR (inits), env), env);
+ env = scm_cons (EVAL1 (CAR (inits), env), env);
if (scm_is_true (rest))
env = scm_cons (args, env);
@@ -903,7 +932,7 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
env = scm_cons (CAR (args), env);
for (; i < nreq + nopt; i++, inits = CDR (inits))
- env = scm_cons (eval (CAR (inits), env), env);
+ env = scm_cons (EVAL1 (CAR (inits), env), env);
if (scm_is_true (rest))
{
@@ -957,7 +986,7 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
{
SCM tail = scm_list_tail (env, SCM_I_MAKINUM (i));
if (SCM_UNBNDP (CAR (tail)))
- SCM_SETCAR (tail, eval (CAR (inits), CDR (tail)));
+ SCM_SETCAR (tail, EVAL1 (CAR (inits), CDR (tail)));
}
}
}
@@ -978,7 +1007,8 @@ prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
&& !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
{
for (; scm_is_pair (exps); exps = CDR (exps), nreq--)
- new_env = scm_cons (eval (CAR (exps), *inout_env), new_env);
+ new_env = scm_cons (EVAL1 (CAR (exps), *inout_env),
+ new_env);
if (SCM_UNLIKELY (nreq != 0))
scm_wrong_num_args (proc);
*out_body = BOOT_CLOSURE_BODY (proc);
@@ -989,11 +1019,12 @@ prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
if (SCM_UNLIKELY (argc < nreq))
scm_wrong_num_args (proc);
for (; nreq; nreq--, exps = CDR (exps))
- new_env = scm_cons (eval (CAR (exps), *inout_env), new_env);
+ new_env = scm_cons (EVAL1 (CAR (exps), *inout_env),
+ new_env);
{
SCM rest = SCM_EOL;
for (; scm_is_pair (exps); exps = CDR (exps))
- rest = scm_cons (eval (CAR (exps), *inout_env), rest);
+ rest = scm_cons (EVAL1 (CAR (exps), *inout_env), rest);
new_env = scm_cons (scm_reverse (rest),
new_env);
}
@@ -1004,7 +1035,7 @@ prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
{
SCM args = SCM_EOL;
for (; scm_is_pair (exps); exps = CDR (exps))
- args = scm_cons (eval (CAR (exps), *inout_env), args);
+ args = scm_cons (EVAL1 (CAR (exps), *inout_env), args);
args = scm_reverse_x (args, SCM_UNDEFINED);
prepare_boot_closure_env_for_apply (proc, args, out_body, inout_env);
}
diff --git a/libguile/gc.c b/libguile/gc.c
index 7d2724c5f..0451fbb42 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -208,6 +208,9 @@ run_before_gc_c_hook (void)
/* GC Statistics Keeping
*/
unsigned long scm_gc_ports_collected = 0;
+static long gc_time_taken = 0;
+static long gc_start_time = 0;
+
static unsigned long protected_obj_count = 0;
@@ -284,7 +287,7 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
gc_times = GC_gc_no;
answer =
- scm_list_n (scm_cons (sym_gc_time_taken, SCM_INUM0),
+ scm_list_n (scm_cons (sym_gc_time_taken, scm_from_long (gc_time_taken)),
scm_cons (sym_heap_size, scm_from_size_t (heap_size)),
scm_cons (sym_heap_free_size, scm_from_size_t (free_bytes)),
scm_cons (sym_heap_total_allocated,
@@ -708,6 +711,36 @@ queue_after_gc_hook (void * hook_data SCM_UNUSED,
return NULL;
}
+
+
+static void *
+start_gc_timer (void * hook_data SCM_UNUSED,
+ void *fn_data SCM_UNUSED,
+ void *data SCM_UNUSED)
+{
+ if (!gc_start_time)
+ gc_start_time = scm_c_get_internal_run_time ();
+
+ return NULL;
+}
+
+static void *
+accumulate_gc_timer (void * hook_data SCM_UNUSED,
+ void *fn_data SCM_UNUSED,
+ void *data SCM_UNUSED)
+{
+ if (gc_start_time)
+ { long now = scm_c_get_internal_run_time ();
+ gc_time_taken += now - gc_start_time;
+ gc_start_time = 0;
+ }
+
+ return NULL;
+}
+
+
+
+
char const *
scm_i_tag_name (scm_t_bits tag)
{
@@ -803,6 +836,8 @@ scm_init_gc ()
SCM_BOOL_F);
scm_c_hook_add (&scm_before_gc_c_hook, queue_after_gc_hook, NULL, 0);
+ scm_c_hook_add (&scm_before_gc_c_hook, start_gc_timer, NULL, 0);
+ scm_c_hook_add (&scm_after_gc_c_hook, accumulate_gc_timer, NULL, 0);
#ifdef HAVE_GC_SET_START_CALLBACK
GC_set_start_callback (run_before_gc_c_hook);
diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c
index 5834346c7..176f25c02 100644
--- a/libguile/gen-scmconfig.c
+++ b/libguile/gen-scmconfig.c
@@ -123,7 +123,6 @@
#include <stdio.h>
#include <string.h>
-#include <uniconv.h>
#define pf printf
@@ -397,11 +396,11 @@ main (int argc, char *argv[])
pf ("\n");
pf ("/* Constants from uniconv.h. */\n");
- pf ("#define SCM_ICONVEH_ERROR %d\n", (int) iconveh_error);
- pf ("#define SCM_ICONVEH_QUESTION_MARK %d\n",
- (int) iconveh_question_mark);
+ pf ("#define SCM_ICONVEH_ERROR %d\n", SCM_I_GSC_ICONVEH_ERROR);
+ pf ("#define SCM_ICONVEH_QUESTION_MARK %d\n",
+ SCM_I_GSC_ICONVEH_QUESTION_MARK);
pf ("#define SCM_ICONVEH_ESCAPE_SEQUENCE %d\n",
- (int) iconveh_escape_sequence);
+ SCM_I_GSC_ICONVEH_ESCAPE_SEQUENCE);
printf ("#endif\n");
diff --git a/libguile/gen-scmconfig.h.in b/libguile/gen-scmconfig.h.in
index 125720acd..30f43d7b7 100644
--- a/libguile/gen-scmconfig.h.in
+++ b/libguile/gen-scmconfig.h.in
@@ -31,6 +31,9 @@
#define SCM_I_GSC_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER @SCM_I_GSC_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER@
#define SCM_I_GSC_HAVE_THREAD_STORAGE_CLASS @SCM_I_GSC_HAVE_THREAD_STORAGE_CLASS@
#define SCM_I_GSC_HAVE_STRUCT_DIRENT64 @SCM_I_GSC_HAVE_STRUCT_DIRENT64@
+#define SCM_I_GSC_ICONVEH_ERROR @SCM_I_GSC_ICONVEH_ERROR@
+#define SCM_I_GSC_ICONVEH_QUESTION_MARK @SCM_I_GSC_ICONVEH_QUESTION_MARK@
+#define SCM_I_GSC_ICONVEH_ESCAPE_SEQUENCE @SCM_I_GSC_ICONVEH_ESCAPE_SEQUENCE@
/*
Local Variables:
diff --git a/libguile/goops.c b/libguile/goops.c
index f6102085f..274749048 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -169,6 +169,8 @@ static SCM class_vm_cont;
static SCM class_bytevector;
static SCM class_uvec;
+static SCM vtable_class_map = SCM_BOOL_F;
+
/* Port classes. Allocate 3 times the maximum number of port types so that
input ports, output ports, and in/out ports can be stored at different
offsets. See `SCM_IN_PCLASS_INDEX' et al. */
@@ -189,6 +191,41 @@ static SCM scm_sys_goops_loaded (void);
static SCM scm_make_extended_class_from_symbol (SCM type_name_sym,
int applicablep);
+
+SCM
+scm_i_define_class_for_vtable (SCM vtable)
+{
+ SCM class;
+
+ if (scm_is_false (vtable_class_map))
+ vtable_class_map = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+
+ if (scm_is_false (scm_struct_vtable_p (vtable)))
+ abort ();
+
+ class = scm_hashq_ref (vtable_class_map, vtable, SCM_BOOL_F);
+
+ if (scm_is_false (class))
+ {
+ if (SCM_UNPACK (scm_class_class))
+ {
+ SCM name = SCM_VTABLE_NAME (vtable);
+ if (!scm_is_symbol (name))
+ name = scm_string_to_symbol (scm_nullstr);
+
+ class = scm_make_extended_class_from_symbol
+ (name, SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_APPLICABLE));
+ }
+ else
+ /* `create_struct_classes' will fill this in later. */
+ class = SCM_BOOL_F;
+
+ scm_hashq_set_x (vtable_class_map, vtable, class);
+ }
+
+ return class;
+}
+
/* This function is used for efficient type dispatch. */
SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
(SCM x),
@@ -288,26 +325,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
return SCM_CLASS_OF (x);
}
else
- {
- /* ordinary struct */
- SCM handle = scm_struct_create_handle (SCM_STRUCT_VTABLE (x));
- if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle))))
- return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle));
- else
- {
- SCM class, name;
-
- name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
- if (!scm_is_symbol (name))
- name = scm_string_to_symbol (scm_nullstr);
-
- class =
- scm_make_extended_class_from_symbol (name,
- SCM_STRUCT_APPLICABLE_P (x));
- SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
- return class;
- }
- }
+ return scm_i_define_class_for_vtable (SCM_CLASS_OF (x));
default:
if (scm_is_pair (x))
return scm_class_pair;
@@ -2628,23 +2646,16 @@ static SCM
make_struct_class (void *closure SCM_UNUSED,
SCM vtable, SCM data, SCM prev SCM_UNUSED)
{
- SCM sym = SCM_STRUCT_TABLE_NAME (data);
- if (scm_is_true (sym))
- {
- int applicablep = SCM_CLASS_FLAGS (vtable) & SCM_VTABLE_FLAG_APPLICABLE;
-
- SCM_SET_STRUCT_TABLE_CLASS (data,
- scm_make_extended_class_from_symbol (sym, applicablep));
- }
-
- scm_remember_upto_here_2 (data, vtable);
+ if (scm_is_false (data))
+ scm_i_define_class_for_vtable (vtable);
return SCM_UNSPECIFIED;
}
static void
create_struct_classes (void)
{
- scm_internal_hash_fold (make_struct_class, 0, SCM_BOOL_F, scm_struct_table);
+ scm_internal_hash_fold (make_struct_class, 0, SCM_BOOL_F,
+ vtable_class_map);
}
/**********************************************************************
diff --git a/libguile/goops.h b/libguile/goops.h
index 06ade43a4..47a6e4eca 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -3,7 +3,7 @@
#ifndef SCM_GOOPS_H
#define SCM_GOOPS_H
-/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -307,6 +307,8 @@ SCM_API SCM scm_apply_generic (SCM gf, SCM args);
*/
SCM_API SCM scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3);
+SCM_INTERNAL SCM scm_i_define_class_for_vtable (SCM vtable);
+
SCM_INTERNAL SCM scm_init_goops_builtins (void);
SCM_INTERNAL void scm_init_goops (void);
diff --git a/libguile/hashtab.c b/libguile/hashtab.c
index 48660d75c..37d168cf4 100644
--- a/libguile/hashtab.c
+++ b/libguile/hashtab.c
@@ -761,21 +761,56 @@ scm_hash_fn_ref (SCM table, SCM obj, SCM dflt,
+struct set_weak_cdr_data
+{
+ SCM pair;
+ SCM new_val;
+};
+
+static void*
+set_weak_cdr (void *data)
+{
+ struct set_weak_cdr_data *d = data;
+
+ if (SCM_NIMP (SCM_WEAK_PAIR_CDR (d->pair)) && !SCM_NIMP (d->new_val))
+ {
+ GC_unregister_disappearing_link ((void *) SCM_CDRLOC (d->pair));
+ SCM_SETCDR (d->pair, d->new_val);
+ }
+ else
+ {
+ SCM_SETCDR (d->pair, d->new_val);
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void *) SCM_CDRLOC (d->pair),
+ SCM2PTR (d->new_val));
+ }
+ return NULL;
+}
+
SCM
scm_hash_fn_set_x (SCM table, SCM obj, SCM val,
scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
void *closure)
{
- SCM it;
+ SCM pair;
- it = scm_hash_fn_create_handle_x (table, obj, SCM_BOOL_F, hash_fn, assoc_fn, closure);
- SCM_SETCDR (it, val);
+ pair = scm_hash_fn_create_handle_x (table, obj, val,
+ hash_fn, assoc_fn, closure);
- if (SCM_HASHTABLE_WEAK_VALUE_P (table) && SCM_NIMP (val))
- /* IT is a weak-cdr pair. Register a disappearing link from IT's
- cdr to VAL like `scm_weak_cdr_pair' does. */
- SCM_I_REGISTER_DISAPPEARING_LINK ((void *) SCM_CDRLOC (it), SCM2PTR (val));
+ if (SCM_UNLIKELY (!scm_is_eq (SCM_CDR (pair), val)))
+ {
+ if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_VALUE_P (table)))
+ {
+ struct set_weak_cdr_data data;
+ data.pair = pair;
+ data.new_val = val;
+
+ GC_call_with_alloc_lock (set_weak_cdr, &data);
+ }
+ else
+ SCM_SETCDR (pair, val);
+ }
+
return val;
}
@@ -843,6 +878,9 @@ SCM_DEFINE (scm_hashq_get_handle, "hashq-get-handle", 2, 0, 0,
"Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_get_handle
{
+ if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
return scm_hash_fn_get_handle (table, key,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
@@ -858,6 +896,9 @@ SCM_DEFINE (scm_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0,
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hashq_create_handle_x
{
+ if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
return scm_hash_fn_create_handle_x (table, key, init,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
@@ -924,6 +965,9 @@ SCM_DEFINE (scm_hashv_get_handle, "hashv-get-handle", 2, 0, 0,
"Uses @code{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_get_handle
{
+ if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
return scm_hash_fn_get_handle (table, key,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
@@ -939,6 +983,9 @@ SCM_DEFINE (scm_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0,
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hashv_create_handle_x
{
+ if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
return scm_hash_fn_create_handle_x (table, key, init,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
@@ -1003,6 +1050,9 @@ SCM_DEFINE (scm_hash_get_handle, "hash-get-handle", 2, 0, 0,
"Uses @code{equal?} for equality testing.")
#define FUNC_NAME s_scm_hash_get_handle
{
+ if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
return scm_hash_fn_get_handle (table, key,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
@@ -1018,6 +1068,9 @@ SCM_DEFINE (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0,
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hash_create_handle_x
{
+ if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
return scm_hash_fn_create_handle_x (table, key, init,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
@@ -1117,6 +1170,10 @@ SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0,
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
+
+ if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
return scm_hash_fn_get_handle (table, key, scm_ihashx, scm_sloppy_assx,
(void *) &closure);
}
@@ -1136,6 +1193,10 @@ SCM_DEFINE (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0,
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
+
+ if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
return scm_hash_fn_create_handle_x (table, key, init, scm_ihashx,
scm_sloppy_assx, (void *)&closure);
}
@@ -1265,6 +1326,9 @@ SCM_DEFINE (scm_hash_for_each_handle, "hash-for-each-handle", 2, 0, 0,
SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, 1, FUNC_NAME);
SCM_VALIDATE_HASHTABLE (2, table);
+ if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn) scm_call_1,
(void *) SCM_UNPACK (proc),
table);
diff --git a/libguile/objprop.c b/libguile/objprop.c
index dfa849441..7b50d71d0 100644
--- a/libguile/objprop.c
+++ b/libguile/objprop.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996, 2000, 2001, 2003, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996, 2000, 2001, 2003, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -59,11 +59,8 @@ SCM_DEFINE (scm_set_object_properties_x, "set-object-properties!", 2, 0, 0,
"Set @var{obj}'s property list to @var{alist}.")
#define FUNC_NAME s_scm_set_object_properties_x
{
- SCM handle;
-
scm_i_pthread_mutex_lock (&whash_mutex);
- handle = scm_hashq_create_handle_x (object_whash, obj, alist);
- SCM_SETCDR (handle, alist);
+ scm_hashq_set_x (object_whash, obj, alist);
scm_i_pthread_mutex_unlock (&whash_mutex);
return alist;
@@ -87,19 +84,16 @@ SCM_DEFINE (scm_set_object_property_x, "set-object-property!", 3, 0, 0,
"to @var{value}.")
#define FUNC_NAME s_scm_set_object_property_x
{
- SCM h;
+ SCM alist;
SCM assoc;
scm_i_pthread_mutex_lock (&whash_mutex);
- h = scm_hashq_create_handle_x (object_whash, obj, SCM_EOL);
- assoc = scm_assq (key, SCM_CDR (h));
+ alist = scm_hashq_ref (object_whash, obj, SCM_EOL);
+ assoc = scm_assq (key, alist);
if (SCM_NIMP (assoc))
SCM_SETCDR (assoc, value);
else
- {
- assoc = scm_acons (key, value, SCM_CDR (h));
- SCM_SETCDR (h, assoc);
- }
+ scm_hashq_set_x (object_whash, obj, scm_acons (key, value, alist));
scm_i_pthread_mutex_unlock (&whash_mutex);
return value;
diff --git a/libguile/read.c b/libguile/read.c
index 4b6828b8a..b36c27c81 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -442,14 +442,14 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
exit:
if (SCM_RECORD_POSITIONS_P)
- scm_whash_insert (scm_source_whash,
- ans,
- scm_make_srcprops (line, column,
- SCM_FILENAME (port),
- SCM_COPY_SOURCE_P
- ? ans2
- : SCM_UNDEFINED,
- SCM_EOL));
+ scm_hashq_set_x (scm_source_whash,
+ ans,
+ scm_make_srcprops (line, column,
+ SCM_FILENAME (port),
+ SCM_COPY_SOURCE_P
+ ? ans2
+ : SCM_UNDEFINED,
+ SCM_EOL));
return ans;
}
#undef FUNC_NAME
@@ -805,15 +805,15 @@ scm_read_quote (int chr, SCM port)
p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
if (SCM_RECORD_POSITIONS_P)
- scm_whash_insert (scm_source_whash, p,
- scm_make_srcprops (line, column,
- SCM_FILENAME (port),
- SCM_COPY_SOURCE_P
- ? (scm_cons2 (SCM_CAR (p),
- SCM_CAR (SCM_CDR (p)),
- SCM_EOL))
- : SCM_UNDEFINED,
- SCM_EOL));
+ scm_hashq_set_x (scm_source_whash, p,
+ scm_make_srcprops (line, column,
+ SCM_FILENAME (port),
+ SCM_COPY_SOURCE_P
+ ? (scm_cons2 (SCM_CAR (p),
+ SCM_CAR (SCM_CDR (p)),
+ SCM_EOL))
+ : SCM_UNDEFINED,
+ SCM_EOL));
return p;
@@ -864,15 +864,15 @@ scm_read_syntax (int chr, SCM port)
p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
if (SCM_RECORD_POSITIONS_P)
- scm_whash_insert (scm_source_whash, p,
- scm_make_srcprops (line, column,
- SCM_FILENAME (port),
- SCM_COPY_SOURCE_P
- ? (scm_cons2 (SCM_CAR (p),
- SCM_CAR (SCM_CDR (p)),
- SCM_EOL))
- : SCM_UNDEFINED,
- SCM_EOL));
+ scm_hashq_set_x (scm_source_whash, p,
+ scm_make_srcprops (line, column,
+ SCM_FILENAME (port),
+ SCM_COPY_SOURCE_P
+ ? (scm_cons2 (SCM_CAR (p),
+ SCM_CAR (SCM_CDR (p)),
+ SCM_EOL))
+ : SCM_UNDEFINED,
+ SCM_EOL));
return p;
@@ -1561,7 +1561,7 @@ recsexpr (SCM obj, long line, int column, SCM filename)
/* If this sexpr is visible in the read:sharp source, we want to
keep that information, so only record non-constant cons cells
which haven't previously been read by the reader. */
- if (scm_is_false (scm_whash_lookup (scm_source_whash, obj)))
+ if (scm_is_false (scm_hashq_ref (scm_source_whash, obj, SCM_BOOL_F)))
{
if (SCM_COPY_SOURCE_P)
{
@@ -1585,13 +1585,13 @@ recsexpr (SCM obj, long line, int column, SCM filename)
recsexpr (SCM_CAR (tmp), line, column, filename);
copy = SCM_UNDEFINED;
}
- scm_whash_insert (scm_source_whash,
- obj,
- scm_make_srcprops (line,
- column,
- filename,
- copy,
- SCM_EOL));
+ scm_hashq_set_x (scm_source_whash,
+ obj,
+ scm_make_srcprops (line,
+ column,
+ filename,
+ copy,
+ SCM_EOL));
}
return obj;
}
diff --git a/libguile/srcprop.c b/libguile/srcprop.c
index 003abc56d..f9b000c47 100644
--- a/libguile/srcprop.c
+++ b/libguile/srcprop.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2006, 2008, 2009, 2010 Free Software Foundation
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2006, 2008, 2009, 2010, 2011 Free Software Foundation
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -180,10 +180,8 @@ SCM_DEFINE (scm_set_source_properties_x, "set-source-properties!", 2, 0, 0,
"list for @var{obj}.")
#define FUNC_NAME s_scm_set_source_properties_x
{
- SCM handle;
SCM_VALIDATE_NIM (1, obj);
- handle = scm_hashq_create_handle_x (scm_source_whash, obj, alist);
- SCM_SETCDR (handle, alist);
+ scm_hashq_set_x (scm_source_whash, obj, alist);
return alist;
}
#undef FUNC_NAME
@@ -222,49 +220,43 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0,
"@var{key} to @var{datum}. Normally, the key will be a symbol.")
#define FUNC_NAME s_scm_set_source_property_x
{
- scm_whash_handle h;
SCM p;
SCM_VALIDATE_NIM (1, obj);
- h = scm_whash_get_handle (scm_source_whash, obj);
- if (SCM_WHASHFOUNDP (h))
- p = SCM_WHASHREF (scm_source_whash, h);
- else
- {
- h = scm_whash_create_handle (scm_source_whash, obj);
- p = SCM_EOL;
- }
+ p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
if (scm_is_eq (scm_sym_line, key))
{
if (SRCPROPSP (p))
SETSRCPROPLINE (p, scm_to_int (datum));
else
- SCM_WHASHSET (scm_source_whash, h,
- scm_make_srcprops (scm_to_int (datum), 0,
- SCM_UNDEFINED, SCM_UNDEFINED, p));
+ scm_hashq_set_x (scm_source_whash, obj,
+ scm_make_srcprops (scm_to_int (datum), 0,
+ SCM_UNDEFINED, SCM_UNDEFINED, p));
}
else if (scm_is_eq (scm_sym_column, key))
{
if (SRCPROPSP (p))
SETSRCPROPCOL (p, scm_to_int (datum));
else
- SCM_WHASHSET (scm_source_whash, h,
- scm_make_srcprops (0, scm_to_int (datum),
- SCM_UNDEFINED, SCM_UNDEFINED, p));
+ scm_hashq_set_x (scm_source_whash, obj,
+ scm_make_srcprops (0, scm_to_int (datum),
+ SCM_UNDEFINED, SCM_UNDEFINED, p));
}
else if (scm_is_eq (scm_sym_copy, key))
{
if (SRCPROPSP (p))
SETSRCPROPCOPY (p, datum);
else
- SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p));
+ scm_hashq_set_x (scm_source_whash, obj,
+ scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p));
}
else
{
if (SRCPROPSP (p))
SETSRCPROPALIST (p, scm_acons (key, datum, SRCPROPALIST (p)));
else
- SCM_WHASHSET (scm_source_whash, h, scm_acons (key, datum, p));
+ scm_hashq_set_x (scm_source_whash, obj,
+ scm_acons (key, datum, p));
}
return SCM_UNSPECIFIED;
}
@@ -281,9 +273,9 @@ SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0,
SCM p, z;
z = scm_cons (x, y);
/* Copy source properties possibly associated with xorig. */
- p = scm_whash_lookup (scm_source_whash, xorig);
+ p = scm_hashq_ref (scm_source_whash, xorig, SCM_BOOL_F);
if (scm_is_true (p))
- scm_whash_insert (scm_source_whash, z, p);
+ scm_hashq_set_x (scm_source_whash, z, p);
return z;
}
#undef FUNC_NAME
diff --git a/libguile/srcprop.h b/libguile/srcprop.h
index 99b848244..5c9ccb960 100644
--- a/libguile/srcprop.h
+++ b/libguile/srcprop.h
@@ -3,7 +3,7 @@
#ifndef SCM_SRCPROP_H
#define SCM_SRCPROP_H
-/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -27,30 +27,6 @@
-/* {The old whash table interface}
- * *fixme* This is a temporary solution until weak hash table access
- * has been optimized for speed (which is quite necessary, if they are
- * used for recording of source code positions...)
- */
-
-#define scm_whash_handle SCM
-
-#define scm_whash_get_handle(whash, key) \
- scm_hashq_get_handle ((whash), (key))
-#define SCM_WHASHFOUNDP(h) (scm_is_true (h))
-#define SCM_WHASHREF(whash, handle) SCM_CDR (handle)
-#define SCM_WHASHSET(whash, handle, obj) SCM_SETCDR (handle, obj)
-#define scm_whash_create_handle(whash, key) \
- scm_hashq_create_handle_x ((whash), (key), SCM_UNSPECIFIED)
-#define scm_whash_lookup(whash, obj) \
- scm_hashq_ref ((whash), (obj), SCM_BOOL_F)
-#define scm_whash_insert(whash, key, obj) \
-do { \
- register SCM w = (whash); \
- SCM_WHASHSET (w, scm_whash_create_handle (w, key), obj); \
-} while (0)
-
-
/* {Source properties}
*/
#define SCM_PROCTRACEP(x) (scm_is_true (scm_procedure_property (x, scm_sym_trace)))
diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index 5c0750451..f67e60082 100644
--- a/libguile/srfi-1.c
+++ b/libguile/srfi-1.c
@@ -956,43 +956,6 @@ scm_srfi1_for_each (SCM proc, SCM arg1, SCM args)
#undef FUNC_NAME
-SCM_DEFINE (scm_srfi1_member, "member", 2, 1, 0,
- (SCM x, SCM lst, SCM pred),
- "Return the first sublist of @var{lst} whose @sc{car} is equal\n"
- "to @var{x}. If @var{x} does not appear in @var{lst}, return\n"
- "@code{#f}.\n"
- "\n"
- "Equality is determined by @code{equal?}, or by the equality\n"
- "predicate @var{=} if given. @var{=} is called @code{(= @var{x}\n"
- "elem)}, ie.@: with the given @var{x} first, so for example to\n"
- "find the first element greater than 5,\n"
- "\n"
- "@example\n"
- "(member 5 '(3 5 1 7 2 9) <) @result{} (7 2 9)\n"
- "@end example\n"
- "\n"
- "This version of @code{member} extends the core @code{member} by\n"
- "accepting an equality predicate.")
-#define FUNC_NAME s_scm_srfi1_member
-{
- scm_t_trampoline_2 equal_p;
- SCM_VALIDATE_LIST (2, lst);
- if (SCM_UNBNDP (pred))
- equal_p = equal_trampoline;
- else
- {
- SCM_VALIDATE_PROC (SCM_ARG3, pred);
- equal_p = scm_call_2;
- }
- for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
- {
- if (scm_is_true (equal_p (pred, x, SCM_CAR (lst))))
- return lst;
- }
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_srfi1_assoc, "assoc", 2, 1, 0,
(SCM key, SCM alist, SCM pred),
"Behaves like @code{assq} but uses third argument @var{pred?}\n"
diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h
index 593d9bb02..85aa65d0c 100644
--- a/libguile/srfi-1.h
+++ b/libguile/srfi-1.h
@@ -1,6 +1,6 @@
/* srfi-1.h --- SRFI-1 procedures for Guile
*
- * Copyright (C) 2002, 2003, 2005, 2006, 2010 Free Software Foundation, Inc.
+ * Copyright (C) 2002, 2003, 2005, 2006, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -41,7 +41,6 @@ SCM_INTERNAL SCM scm_srfi1_lset_difference_x (SCM equal, SCM lst, SCM rest);
SCM_INTERNAL SCM scm_srfi1_list_copy (SCM lst);
SCM_INTERNAL SCM scm_srfi1_map (SCM proc, SCM arg1, SCM args);
SCM_INTERNAL SCM scm_srfi1_for_each (SCM proc, SCM arg1, SCM args);
-SCM_INTERNAL SCM scm_srfi1_member (SCM obj, SCM ls, SCM pred);
SCM_INTERNAL SCM scm_srfi1_assoc (SCM key, SCM alist, SCM pred);
SCM_INTERNAL SCM scm_srfi1_partition (SCM pred, SCM list);
SCM_INTERNAL SCM scm_srfi1_partition_x (SCM pred, SCM list);
diff --git a/libguile/stime.c b/libguile/stime.c
index 78aa6731a..1c4f407f9 100644
--- a/libguile/stime.c
+++ b/libguile/stime.c
@@ -64,9 +64,13 @@
#endif
-# ifdef HAVE_SYS_TYPES_H
-# include <sys/types.h>
-# endif
+#ifdef HAVE_CLOCK_GETTIME
+# include <time.h>
+#endif
+
+#ifdef HAVE_SYS_TYPES_H
+# include <sys/types.h>
+#endif
#ifdef HAVE_STRING_H
#include <string.h>
@@ -98,27 +102,98 @@ extern char *strptime ();
#endif
-#ifdef HAVE_TIMES
-static
-timet mytime()
+#if SCM_SIZEOF_LONG >= 8 && defined HAVE_CLOCK_GETTIME
+/* Nanoseconds on 64-bit systems with POSIX timers. */
+#define TIME_UNITS_PER_SECOND 1000000000
+#else
+/* Milliseconds for everyone else. */
+#define TIME_UNITS_PER_SECOND 1000
+#endif
+
+long scm_c_time_units_per_second = TIME_UNITS_PER_SECOND;
+
+static long
+time_from_seconds_and_nanoseconds (long s, long ns)
+{
+ return s * TIME_UNITS_PER_SECOND
+ + ns / (1000000000 / TIME_UNITS_PER_SECOND);
+}
+
+
+/* A runtime-selectable mechanism to choose a timing mechanism. Really
+ we want to use POSIX timers, but that's not always possible. Notably,
+ the user may have everything she needs at compile-time, but if she's
+ running on an SMP machine without a common clock source, she can't
+ use POSIX CPUTIME clocks. */
+static long (*get_internal_real_time) (void);
+static long (*get_internal_run_time) (void);
+
+
+#ifdef HAVE_CLOCK_GETTIME
+struct timespec posix_real_time_base;
+
+static long
+get_internal_real_time_posix_timer (void)
+{
+ struct timespec ts;
+ clock_gettime (CLOCK_REALTIME, &ts);
+ return time_from_seconds_and_nanoseconds
+ (ts.tv_sec - posix_real_time_base.tv_sec,
+ ts.tv_nsec - posix_real_time_base.tv_nsec);
+}
+
+#ifdef _POSIX_CPUTIME
+struct timespec posix_run_time_base;
+
+static long
+get_internal_run_time_posix_timer (void)
+{
+ struct timespec ts;
+ clock_gettime (CLOCK_PROCESS_CPUTIME_ID, &ts);
+ return time_from_seconds_and_nanoseconds
+ (ts.tv_sec - posix_run_time_base.tv_sec,
+ ts.tv_nsec - posix_run_time_base.tv_nsec);
+}
+#endif /* _POSIX_CPUTIME */
+#endif /* HAVE_CLOCKTIME */
+
+
+#ifdef HAVE_GETTIMEOFDAY
+struct timeval gettimeofday_real_time_base;
+
+static long
+get_internal_real_time_gettimeofday (void)
+{
+ struct timeval tv;
+ gettimeofday (&tv, NULL);
+ return time_from_seconds_and_nanoseconds
+ (tv.tv_sec - gettimeofday_real_time_base.tv_sec,
+ (tv.tv_usec - gettimeofday_real_time_base.tv_usec) * 1000);
+}
+#endif
+
+
+#if defined HAVE_TIMES
+static long ticks_per_second;
+
+static long
+get_internal_run_time_times (void)
{
struct tms time_buffer;
times(&time_buffer);
- return time_buffer.tms_utime + time_buffer.tms_stime;
+ return (time_buffer.tms_utime + time_buffer.tms_stime)
+ * TIME_UNITS_PER_SECOND / ticks_per_second;
}
-#else
-# ifdef LACK_CLOCK
-# define mytime() ((time((timet*)0) - scm_your_base) * SCM_TIME_UNITS_PER_SECOND)
-# else
-# define mytime clock
-# endif
#endif
-#ifdef HAVE_FTIME
-struct timeb scm_your_base = {0};
-#else
-timet scm_your_base = 0;
-#endif
+static timet fallback_real_time_base;
+static long
+get_internal_real_time_fallback (void)
+{
+ return time_from_seconds_and_nanoseconds
+ ((long) time (NULL) - fallback_real_time_base, 0);
+}
+
SCM_DEFINE (scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0,
(),
@@ -126,23 +201,7 @@ SCM_DEFINE (scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0,
"started.")
#define FUNC_NAME s_scm_get_internal_real_time
{
-#ifdef HAVE_FTIME
- struct timeb time_buffer;
-
- SCM tmp;
- ftime (&time_buffer);
- time_buffer.time -= scm_your_base.time;
- tmp = scm_from_long (time_buffer.millitm - scm_your_base.millitm);
- tmp = scm_sum (tmp,
- scm_product (scm_from_int (1000),
- scm_from_int (time_buffer.time)));
- return scm_quotient (scm_product (tmp,
- scm_from_int (SCM_TIME_UNITS_PER_SECOND)),
- scm_from_int (1000));
-#else
- return scm_from_long ((time((timet*)0) - scm_your_base)
- * (int)SCM_TIME_UNITS_PER_SECOND);
-#endif /* HAVE_FTIME */
+ return scm_from_long (get_internal_real_time ());
}
#undef FUNC_NAME
@@ -175,27 +234,35 @@ SCM_DEFINE (scm_times, "times", 0, 0, 0,
{
struct tms t;
clock_t rv;
+ SCM factor;
SCM result = scm_c_make_vector (5, SCM_UNDEFINED);
rv = times (&t);
if (rv == -1)
SCM_SYSERROR;
- SCM_SIMPLE_VECTOR_SET (result, 0, scm_from_long (rv));
- SCM_SIMPLE_VECTOR_SET (result, 1, scm_from_long (t.tms_utime));
- SCM_SIMPLE_VECTOR_SET (result, 2, scm_from_long (t.tms_stime));
- SCM_SIMPLE_VECTOR_SET (result ,3, scm_from_long (t.tms_cutime));
- SCM_SIMPLE_VECTOR_SET (result, 4, scm_from_long (t.tms_cstime));
+
+ factor = scm_quotient (scm_from_long (TIME_UNITS_PER_SECOND),
+ scm_from_long (ticks_per_second));
+
+ SCM_SIMPLE_VECTOR_SET (result, 0,
+ scm_product (scm_from_long (rv), factor));
+ SCM_SIMPLE_VECTOR_SET (result, 1,
+ scm_product (scm_from_long (t.tms_utime), factor));
+ SCM_SIMPLE_VECTOR_SET (result, 2,
+ scm_product (scm_from_long (t.tms_stime), factor));
+ SCM_SIMPLE_VECTOR_SET (result ,3,
+ scm_product (scm_from_long (t.tms_cutime), factor));
+ SCM_SIMPLE_VECTOR_SET (result, 4,
+ scm_product (scm_from_long (t.tms_cstime), factor));
return result;
}
#undef FUNC_NAME
#endif /* HAVE_TIMES */
-static long scm_my_base = 0;
-
long
-scm_c_get_internal_run_time ()
+scm_c_get_internal_run_time (void)
{
- return mytime () - scm_my_base;
+ return get_internal_run_time ();
}
SCM_DEFINE (scm_get_internal_run_time, "get-internal-run-time", 0, 0, 0,
@@ -243,41 +310,18 @@ SCM_DEFINE (scm_gettimeofday, "gettimeofday", 0, 0, 0,
{
#ifdef HAVE_GETTIMEOFDAY
struct timeval time;
- int ret, err;
- SCM_CRITICAL_SECTION_START;
- ret = gettimeofday (&time, NULL);
- err = errno;
- SCM_CRITICAL_SECTION_END;
- if (ret == -1)
- {
- errno = err;
- SCM_SYSERROR;
- }
+ if (gettimeofday (&time, NULL))
+ SCM_SYSERROR;
+
return scm_cons (scm_from_long (time.tv_sec),
scm_from_long (time.tv_usec));
#else
-# ifdef HAVE_FTIME
- struct timeb time;
-
- ftime(&time);
- return scm_cons (scm_from_long (time.time),
- scm_from_int (time.millitm * 1000));
-# else
- timet timv;
- int err;
-
- SCM_CRITICAL_SECTION_START;
- timv = time (NULL);
- err = errno;
- SCM_CRITICAL_SECTION_END;
- if (timv == -1)
- {
- errno = err;
- SCM_SYSERROR;
- }
- return scm_cons (scm_from_long (timv), scm_from_int (0));
-# endif
+ timet t = time (NULL);
+ if (errno)
+ SCM_SYSERROR;
+ else
+ return scm_cons (scm_from_long ((long)t), SCM_INUM0);
#endif
}
#undef FUNC_NAME
@@ -798,13 +842,55 @@ scm_init_stime()
scm_c_define ("internal-time-units-per-second",
scm_from_long (SCM_TIME_UNITS_PER_SECOND));
-#ifdef HAVE_FTIME
- if (!scm_your_base.time) ftime(&scm_your_base);
+ /* Init POSIX timers, and see if we can use them. */
+#ifdef HAVE_CLOCK_GETTIME
+ if (clock_gettime (CLOCK_REALTIME, &posix_real_time_base) == 0)
+ get_internal_real_time = get_internal_real_time_posix_timer;
+
+#ifdef _POSIX_CPUTIME
+ {
+ clockid_t dummy;
+
+ /* Only use the _POSIX_CPUTIME clock if it's going to work across
+ CPUs. */
+ if (clock_getcpuclockid (0, &dummy) == 0 &&
+ clock_gettime (CLOCK_PROCESS_CPUTIME_ID, &posix_run_time_base) == 0)
+ get_internal_run_time = get_internal_run_time_posix_timer;
+ else
+ errno = 0;
+ }
+#endif /* _POSIX_CPUTIME */
+#endif /* HAVE_CLOCKTIME */
+
+ /* If needed, init and use gettimeofday timer. */
+#ifdef HAVE_GETTIMEOFDAY
+ if (!get_internal_real_time
+ && gettimeofday (&gettimeofday_real_time_base, NULL) == 0)
+ get_internal_real_time = get_internal_real_time_gettimeofday;
+#endif
+
+ /* Init ticks_per_second for scm_times, and use times(2)-based
+ run-time timer if needed. */
+#ifdef HAVE_TIMES
+#ifdef _SC_CLK_TCK
+ ticks_per_second = sysconf (_SC_CLK_TCK);
#else
- if (!scm_your_base) time(&scm_your_base);
+ ticks_per_second = CLK_TCK;
#endif
+ if (!get_internal_run_time)
+ get_internal_run_time = get_internal_run_time_times;
+#endif
+
+ if (!get_internal_real_time)
+ /* No POSIX timers, gettimeofday doesn't work... badness! */
+ {
+ fallback_real_time_base = time (NULL);
+ get_internal_real_time = get_internal_real_time_fallback;
+ }
- if (!scm_my_base) scm_my_base = mytime();
+ /* If we don't have a run-time timer, use real-time. */
+ if (!get_internal_run_time)
+ get_internal_run_time = get_internal_real_time;
scm_add_feature ("current-time");
#include "libguile/stime.x"
diff --git a/libguile/stime.h b/libguile/stime.h
index 8b70cee62..e41f79730 100644
--- a/libguile/stime.h
+++ b/libguile/stime.h
@@ -3,7 +3,7 @@
#ifndef SCM_STIME_H
#define SCM_STIME_H
-/* Copyright (C) 1995,1996,1997,1998,2000, 2003, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000, 2003, 2006, 2008, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -25,32 +25,10 @@
#include "libguile/__scm.h"
-#include <unistd.h> /* for sysconf */
-
-/* This should be figured out by autoconf.
-
- sysconf(_SC_CLK_TCK) is best, since it's the actual running kernel, not
- some compile-time CLK_TCK. On glibc 2.3.2 CLK_TCK (when defined) is in
- fact sysconf(_SC_CLK_TCK) anyway.
-
- CLK_TCK is obsolete in POSIX. In glibc 2.3.2 it's defined by default,
- but if you define _GNU_SOURCE or _POSIX_C_SOURCE to get other features
- then it goes away. */
-
-#if ! defined(SCM_TIME_UNITS_PER_SECOND) && defined(_SC_CLK_TCK)
-# define SCM_TIME_UNITS_PER_SECOND ((int) sysconf (_SC_CLK_TCK))
-#endif
-#if ! defined(SCM_TIME_UNITS_PER_SECOND) && defined(CLK_TCK)
-# define SCM_TIME_UNITS_PER_SECOND ((int) CLK_TCK)
-#endif
-#if ! defined(SCM_TIME_UNITS_PER_SECOND) && defined(CLOCKS_PER_SEC)
-# define SCM_TIME_UNITS_PER_SECOND ((int) CLOCKS_PER_SEC)
-#endif
-#if ! defined(SCM_TIME_UNITS_PER_SECOND)
-# define SCM_TIME_UNITS_PER_SECOND 60
-#endif
+SCM_API long scm_c_time_units_per_second;
+#define SCM_TIME_UNITS_PER_SECOND scm_c_time_units_per_second
SCM_API long scm_c_get_internal_run_time (void);
diff --git a/libguile/struct.c b/libguile/struct.c
index e5ecc1aaf..4a2a9d750 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -54,7 +54,6 @@
static SCM required_vtable_fields = SCM_BOOL_F;
static SCM required_applicable_fields = SCM_BOOL_F;
static SCM required_applicable_with_setter_fields = SCM_BOOL_F;
-SCM scm_struct_table = SCM_BOOL_F;
SCM scm_applicable_struct_vtable_vtable;
SCM scm_applicable_struct_with_setter_vtable_vtable;
SCM scm_standard_vtable_vtable;
@@ -946,27 +945,13 @@ scm_struct_ihashq (SCM obj, unsigned long n, void *closure)
return SCM_UNPACK (obj) % n;
}
-SCM
-scm_struct_create_handle (SCM obj)
-{
- SCM handle = scm_hash_fn_create_handle_x (scm_struct_table,
- obj,
- SCM_BOOL_F,
- scm_struct_ihashq,
- (scm_t_assoc_fn) scm_sloppy_assq,
- 0);
- if (scm_is_false (SCM_CDR (handle)))
- SCM_SETCDR (handle, scm_cons (SCM_BOOL_F, SCM_BOOL_F));
- return handle;
-}
-
SCM_DEFINE (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0,
(SCM vtable),
"Return the name of the vtable @var{vtable}.")
#define FUNC_NAME s_scm_struct_vtable_name
{
SCM_VALIDATE_VTABLE (1, vtable);
- return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)));
+ return SCM_VTABLE_NAME (vtable);
}
#undef FUNC_NAME
@@ -977,8 +962,10 @@ SCM_DEFINE (scm_set_struct_vtable_name_x, "set-struct-vtable-name!", 2, 0, 0,
{
SCM_VALIDATE_VTABLE (1, vtable);
SCM_VALIDATE_SYMBOL (2, name);
- SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)),
- name);
+ SCM_SET_VTABLE_NAME (vtable, name);
+ /* FIXME: remove this, and implement proper struct classes instead.
+ (Vtables *are* classes.) */
+ scm_i_define_class_for_vtable (vtable);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -1047,7 +1034,6 @@ scm_init_struct ()
OBJ once OBJ has undergone class redefinition. */
GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits));
- scm_struct_table = scm_make_weak_key_hash_table (scm_from_int (31));
required_vtable_fields = scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT);
required_applicable_fields = scm_from_locale_string (SCM_APPLICABLE_BASE_LAYOUT);
required_applicable_with_setter_fields = scm_from_locale_string (SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT);
diff --git a/libguile/struct.h b/libguile/struct.h
index 7a4d63521..c3c7d8f12 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -3,7 +3,7 @@
#ifndef SCM_STRUCT_H
#define SCM_STRUCT_H
-/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -165,12 +165,6 @@ typedef void (*scm_t_struct_finalize) (SCM obj);
#define SCM_STRUCT_SETTER(X) (SCM_STRUCT_SLOT_REF (X, scm_applicable_struct_index_setter))
#define SCM_SET_STRUCT_SETTER(X,P) (SCM_STRUCT_SLOT_SET (X, scm_applicable_struct_index_setter, P))
-#define SCM_STRUCT_TABLE_NAME(X) SCM_CAR (X)
-#define SCM_SET_STRUCT_TABLE_NAME(X, NAME) SCM_SETCAR (X, NAME)
-#define SCM_STRUCT_TABLE_CLASS(X) SCM_CDR (X)
-#define SCM_SET_STRUCT_TABLE_CLASS(X, CLASS) SCM_SETCDR (X, CLASS)
-SCM_API SCM scm_struct_table;
-
SCM_API SCM scm_standard_vtable_vtable;
SCM_API SCM scm_applicable_struct_vtable_vtable;
SCM_API SCM scm_applicable_struct_with_setter_vtable_vtable;
@@ -191,7 +185,6 @@ SCM_API SCM scm_struct_ref (SCM handle, SCM pos);
SCM_API SCM scm_struct_set_x (SCM handle, SCM pos, SCM val);
SCM_API SCM scm_struct_vtable (SCM handle);
SCM_API SCM scm_struct_vtable_tag (SCM handle);
-SCM_API SCM scm_struct_create_handle (SCM obj);
SCM_API SCM scm_struct_vtable_name (SCM vtable);
SCM_API SCM scm_set_struct_vtable_name_x (SCM vtable, SCM name);
SCM_API void scm_print_struct (SCM exp, SCM port, scm_print_state *);
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 4b0ca3ec3..bfa848967 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -20,12 +20,14 @@
#if (VM_ENGINE == SCM_VM_REGULAR_ENGINE)
#define VM_USE_HOOKS 0 /* Various hooks */
-#define VM_CHECK_OBJECT 1 /* Check object table */
-#define VM_CHECK_FREE_VARIABLES 1 /* Check free variable access */
+#define VM_CHECK_OBJECT 0 /* Check object table */
+#define VM_CHECK_FREE_VARIABLES 0 /* Check free variable access */
+#define VM_CHECK_UNDERFLOW 0 /* Check underflow when popping values */
#elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
#define VM_USE_HOOKS 1
-#define VM_CHECK_OBJECT 1
-#define VM_CHECK_FREE_VARIABLES 1
+#define VM_CHECK_OBJECT 0
+#define VM_CHECK_FREE_VARIABLES 0
+#define VM_CHECK_UNDERFLOW 0 /* Check underflow when popping values */
#else
#error unknown debug engine VM_ENGINE
#endif
@@ -45,7 +47,9 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
/* Cache variables */
struct scm_objcode *bp = NULL; /* program base pointer */
SCM *objects = NULL; /* constant objects */
+#if VM_CHECK_OBJECT
size_t object_count = 0; /* length of OBJECTS */
+#endif
SCM *stack_limit = vp->stack_limit; /* stack limit address */
SCM dynstate = SCM_I_CURRENT_THREAD->dynamic_state;
@@ -134,21 +138,21 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
/* FIXME: need to sync regs before allocating anything, in each case. */
vm_error_bad_instruction:
- err_msg = scm_from_locale_string ("VM: Bad instruction: ~s");
+ err_msg = scm_from_latin1_string ("VM: Bad instruction: ~s");
finish_args = scm_list_1 (scm_from_uchar (ip[-1]));
goto vm_error;
vm_error_unbound:
/* FINISH_ARGS should be the name of the unbound variable. */
SYNC_ALL ();
- err_msg = scm_from_locale_string ("Unbound variable: ~s");
+ err_msg = scm_from_latin1_string ("Unbound variable: ~s");
scm_error_scm (scm_misc_error_key, program, err_msg,
scm_list_1 (finish_args), SCM_BOOL_F);
goto vm_error;
vm_error_unbound_fluid:
SYNC_ALL ();
- err_msg = scm_from_locale_string ("Unbound fluid: ~s");
+ err_msg = scm_from_latin1_string ("Unbound fluid: ~s");
scm_error_scm (scm_misc_error_key, program, err_msg,
scm_list_1 (finish_args), SCM_BOOL_F);
goto vm_error;
@@ -167,26 +171,26 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
vm_error_kwargs_length_not_even:
SYNC_ALL ();
- err_msg = scm_from_locale_string ("Odd length of keyword argument list");
+ err_msg = scm_from_latin1_string ("Odd length of keyword argument list");
scm_error_scm (sym_keyword_argument_error, program, err_msg,
SCM_EOL, SCM_BOOL_F);
vm_error_kwargs_invalid_keyword:
/* FIXME say which one it was */
SYNC_ALL ();
- err_msg = scm_from_locale_string ("Invalid keyword");
+ err_msg = scm_from_latin1_string ("Invalid keyword");
scm_error_scm (sym_keyword_argument_error, program, err_msg,
SCM_EOL, SCM_BOOL_F);
vm_error_kwargs_unrecognized_keyword:
/* FIXME say which one it was */
SYNC_ALL ();
- err_msg = scm_from_locale_string ("Unrecognized keyword");
+ err_msg = scm_from_latin1_string ("Unrecognized keyword");
scm_error_scm (sym_keyword_argument_error, program, err_msg,
SCM_EOL, SCM_BOOL_F);
vm_error_too_many_args:
- err_msg = scm_from_locale_string ("VM: Too many arguments");
+ err_msg = scm_from_latin1_string ("VM: Too many arguments");
finish_args = scm_list_1 (scm_from_int (nargs));
goto vm_error;
@@ -204,7 +208,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
goto vm_error;
vm_error_stack_overflow:
- err_msg = scm_from_locale_string ("VM: Stack overflow");
+ err_msg = scm_from_latin1_string ("VM: Stack overflow");
finish_args = SCM_EOL;
if (stack_limit < vp->stack_base + vp->stack_size)
/* There are VM_STACK_RESERVE_SIZE bytes left. Make them available so
@@ -213,12 +217,12 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
goto vm_error;
vm_error_stack_underflow:
- err_msg = scm_from_locale_string ("VM: Stack underflow");
+ err_msg = scm_from_latin1_string ("VM: Stack underflow");
finish_args = SCM_EOL;
goto vm_error;
vm_error_improper_list:
- err_msg = scm_from_locale_string ("Expected a proper list, but got object with tail ~s");
+ err_msg = scm_from_latin1_string ("Expected a proper list, but got object with tail ~s");
goto vm_error;
vm_error_not_a_pair:
@@ -246,41 +250,41 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
goto vm_error;
vm_error_no_values:
- err_msg = scm_from_locale_string ("Zero values returned to single-valued continuation");
+ err_msg = scm_from_latin1_string ("Zero values returned to single-valued continuation");
finish_args = SCM_EOL;
goto vm_error;
vm_error_not_enough_values:
- err_msg = scm_from_locale_string ("Too few values returned to continuation");
+ err_msg = scm_from_latin1_string ("Too few values returned to continuation");
finish_args = SCM_EOL;
goto vm_error;
vm_error_continuation_not_rewindable:
- err_msg = scm_from_locale_string ("Unrewindable partial continuation");
+ err_msg = scm_from_latin1_string ("Unrewindable partial continuation");
finish_args = scm_cons (finish_args, SCM_EOL);
goto vm_error;
vm_error_bad_wide_string_length:
- err_msg = scm_from_locale_string ("VM: Bad wide string length: ~S");
+ err_msg = scm_from_latin1_string ("VM: Bad wide string length: ~S");
goto vm_error;
#ifdef VM_CHECK_IP
vm_error_invalid_address:
- err_msg = scm_from_locale_string ("VM: Invalid program address");
+ err_msg = scm_from_latin1_string ("VM: Invalid program address");
finish_args = SCM_EOL;
goto vm_error;
#endif
#if VM_CHECK_OBJECT
vm_error_object:
- err_msg = scm_from_locale_string ("VM: Invalid object table access");
+ err_msg = scm_from_latin1_string ("VM: Invalid object table access");
finish_args = SCM_EOL;
goto vm_error;
#endif
#if VM_CHECK_FREE_VARIABLES
vm_error_free_variable:
- err_msg = scm_from_locale_string ("VM: Invalid free variable access");
+ err_msg = scm_from_latin1_string ("VM: Invalid free variable access");
finish_args = SCM_EOL;
goto vm_error;
#endif
@@ -298,6 +302,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
#undef VM_USE_HOOKS
#undef VM_CHECK_OBJECT
#undef VM_CHECK_FREE_VARIABLE
+#undef VM_CHECK_UNDERFLOW
/*
Local Variables:
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index ad226dc03..abbc11077 100644
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -144,6 +144,12 @@
#define ASSERT_BOUND(x)
#endif
+#if VM_CHECK_OBJECT
+#define SET_OBJECT_COUNT(n) object_count = n
+#else
+#define SET_OBJECT_COUNT(n) /* nop */
+#endif
+
/* Cache the object table and free variables. */
#define CACHE_PROGRAM() \
{ \
@@ -152,10 +158,10 @@
ASSERT_ALIGNED_PROCEDURE (); \
if (SCM_I_IS_VECTOR (SCM_PROGRAM_OBJTABLE (program))) { \
objects = SCM_I_VECTOR_WELTS (SCM_PROGRAM_OBJTABLE (program)); \
- object_count = SCM_I_VECTOR_LENGTH (SCM_PROGRAM_OBJTABLE (program)); \
+ SET_OBJECT_COUNT (SCM_I_VECTOR_LENGTH (SCM_PROGRAM_OBJTABLE (program))); \
} else { \
objects = NULL; \
- object_count = 0; \
+ SET_OBJECT_COUNT (0); \
} \
} \
}
@@ -266,18 +272,26 @@
if (SCM_UNLIKELY (sp >= stack_limit)) \
goto vm_error_stack_overflow
+
+#ifdef VM_CHECK_UNDERFLOW
#define CHECK_UNDERFLOW() \
if (SCM_UNLIKELY (sp <= SCM_FRAME_UPPER_ADDRESS (fp))) \
- goto vm_error_stack_underflow;
-
+ goto vm_error_stack_underflow
#define PRE_CHECK_UNDERFLOW(N) \
if (SCM_UNLIKELY (sp - N <= SCM_FRAME_UPPER_ADDRESS (fp))) \
- goto vm_error_stack_underflow;
+ goto vm_error_stack_underflow
+#else
+#define CHECK_UNDERFLOW() /* nop */
+#define PRE_CHECK_UNDERFLOW(N) /* nop */
+#endif
+
#define PUSH(x) do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
#define DROP() do { sp--; CHECK_UNDERFLOW (); NULLSTACK (1); } while (0)
#define DROPN(_n) do { sp -= (_n); CHECK_UNDERFLOW (); NULLSTACK (_n); } while (0)
#define POP(x) do { PRE_CHECK_UNDERFLOW (1); x = *sp--; NULLSTACK (1); } while (0)
+#define POP2(x,y) do { PRE_CHECK_UNDERFLOW (2); x = *sp--; y = *sp--; NULLSTACK (2); } while (0)
+#define POP3(x,y,z) do { PRE_CHECK_UNDERFLOW (3); x = *sp--; y = *sp--; z = *sp--; NULLSTACK (3); } while (0)
/* A fast CONS. This has to be fast since its used, for instance, by
POP_LIST when fetching a function's argument list. Note: `scm_cell' is an
diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c
index 0d8678485..6fa8eb2ea 100644
--- a/libguile/vm-i-loader.c
+++ b/libguile/vm-i-loader.c
@@ -92,8 +92,7 @@ VM_DEFINE_LOADER (106, load_array, "load-array")
SCM type, shape;
size_t len;
FETCH_LENGTH (len);
- POP (shape);
- POP (type);
+ POP2 (shape, type);
SYNC_REGISTER ();
PUSH (scm_from_contiguous_typed_array (type, shape, ip, len));
ip += len;
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index 9e249bc85..60e44521e 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -147,8 +147,7 @@ VM_DEFINE_FUNCTION (142, cdr, "cdr", 1)
VM_DEFINE_INSTRUCTION (143, set_car, "set-car!", 0, 2, 0)
{
SCM x, y;
- POP (y);
- POP (x);
+ POP2 (y, x);
VM_VALIDATE_CONS (x, "set-car!");
SCM_SETCAR (x, y);
NEXT;
@@ -157,8 +156,7 @@ VM_DEFINE_INSTRUCTION (143, set_car, "set-car!", 0, 2, 0)
VM_DEFINE_INSTRUCTION (144, set_cdr, "set-cdr!", 0, 2, 0)
{
SCM x, y;
- POP (y);
- POP (x);
+ POP2 (y, x);
VM_VALIDATE_CONS (x, "set-cdr!");
SCM_SETCDR (x, y);
NEXT;
@@ -469,7 +467,7 @@ VM_DEFINE_INSTRUCTION (164, vector_set, "vector-set", 0, 3, 0)
{
scm_t_signed_bits i = 0;
SCM vect, idx, val;
- POP (val); POP (idx); POP (vect);
+ POP3 (val, idx, vect);
if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
&& SCM_I_INUMP (idx)
&& ((i = SCM_I_INUM (idx)) >= 0)
@@ -645,9 +643,7 @@ VM_DEFINE_INSTRUCTION (173, slot_set, "slot-set", 0, 3, 0)
{
SCM instance, idx, val;
size_t slot;
- POP (val);
- POP (idx);
- POP (instance);
+ POP3 (val, idx, instance);
slot = SCM_I_INUM (idx);
SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val);
NEXT;
@@ -820,7 +816,7 @@ BV_FLOAT_REF (f64, ieee_double, double, 8)
if (scm_is_eq (endianness, scm_i_native_endianness)) \
goto VM_LABEL (bv_##stem##_native_set); \
{ \
- SCM bv, idx, val; POP (val); POP (idx); POP (bv); \
+ SCM bv, idx, val; POP3 (val, idx, bv); \
SYNC_REGISTER (); \
scm_bytevector_##fn_stem##_set_x (bv, idx, val, endianness); \
NEXT; \
@@ -852,7 +848,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double)
SCM bv, idx, val; \
scm_t_ ## type *int_ptr; \
\
- POP (val); POP (idx); POP (bv); \
+ POP3 (val, idx, bv); \
VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
i = SCM_I_INUM (idx); \
int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
@@ -879,7 +875,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double)
SCM bv, idx, val; \
scm_t_ ## type *int_ptr; \
\
- POP (val); POP (idx); POP (bv); \
+ POP3 (val, idx, bv); \
VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
i = SCM_I_INUM (idx); \
int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
@@ -903,7 +899,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double)
SCM bv, idx, val; \
type *float_ptr; \
\
- POP (val); POP (idx); POP (bv); \
+ POP3 (val, idx, bv); \
VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
i = SCM_I_INUM (idx); \
float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 71c5281c8..ea00fc920 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -397,18 +397,20 @@ VM_DEFINE_INSTRUCTION (28, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
VM_DEFINE_INSTRUCTION (29, local_set, "local-set", 1, 1, 0)
{
- LOCAL_SET (FETCH (), *sp);
- DROP ();
+ SCM x;
+ POP (x);
+ LOCAL_SET (FETCH (), x);
NEXT;
}
VM_DEFINE_INSTRUCTION (30, long_local_set, "long-local-set", 2, 1, 0)
{
+ SCM x;
unsigned int i = FETCH ();
i <<= 8;
i += FETCH ();
- LOCAL_SET (i, *sp);
- DROP ();
+ POP (x);
+ LOCAL_SET (i, x);
NEXT;
}
@@ -479,7 +481,7 @@ VM_DEFINE_INSTRUCTION (33, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
offset -= (offset & (1<<23)) << 1; \
}
-#define BR(p) \
+#define BR(p) \
{ \
scm_t_int32 offset; \
FETCH_OFFSET (offset); \
@@ -487,8 +489,6 @@ VM_DEFINE_INSTRUCTION (33, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
ip += offset; \
if (offset < 0) \
VM_HANDLE_INTERRUPTS; \
- NULLSTACK (1); \
- DROP (); \
NEXT; \
}
@@ -504,34 +504,44 @@ VM_DEFINE_INSTRUCTION (34, br, "br", 3, 0, 0)
VM_DEFINE_INSTRUCTION (35, br_if, "br-if", 3, 0, 0)
{
- BR (scm_is_true (*sp));
+ SCM x;
+ POP (x);
+ BR (scm_is_true (x));
}
VM_DEFINE_INSTRUCTION (36, br_if_not, "br-if-not", 3, 0, 0)
{
- BR (scm_is_false (*sp));
+ SCM x;
+ POP (x);
+ BR (scm_is_false (x));
}
VM_DEFINE_INSTRUCTION (37, br_if_eq, "br-if-eq", 3, 0, 0)
{
- sp--; /* underflow? */
- BR (scm_is_eq (sp[0], sp[1]));
+ SCM x, y;
+ POP2 (y, x);
+ BR (scm_is_eq (x, y));
}
VM_DEFINE_INSTRUCTION (38, br_if_not_eq, "br-if-not-eq", 3, 0, 0)
{
- sp--; /* underflow? */
- BR (!scm_is_eq (sp[0], sp[1]));
+ SCM x, y;
+ POP2 (y, x);
+ BR (!scm_is_eq (x, y));
}
VM_DEFINE_INSTRUCTION (39, br_if_null, "br-if-null", 3, 0, 0)
{
- BR (scm_is_null (*sp));
+ SCM x;
+ POP (x);
+ BR (scm_is_null (x));
}
VM_DEFINE_INSTRUCTION (40, br_if_not_null, "br-if-not-null", 3, 0, 0)
{
- BR (!scm_is_null (*sp));
+ SCM x;
+ POP (x);
+ BR (!scm_is_null (x));
}
@@ -1029,8 +1039,7 @@ VM_DEFINE_INSTRUCTION (58, continuation_call, "continuation-call", 0, -1, 0)
VM_DEFINE_INSTRUCTION (59, partial_cont_call, "partial-cont-call", 0, -1, 0)
{
SCM vmcont, intwinds, prevwinds;
- POP (intwinds);
- POP (vmcont);
+ POP2 (intwinds, vmcont);
SYNC_REGISTER ();
if (SCM_UNLIKELY (!SCM_VM_CONT_REWINDABLE_P (vmcont)))
{ finish_args = vmcont;
@@ -1512,8 +1521,7 @@ VM_DEFINE_INSTRUCTION (81, fix_closure, "fix-closure", 2, -1, 0)
VM_DEFINE_INSTRUCTION (82, define, "define", 0, 0, 2)
{
SCM sym, val;
- POP (sym);
- POP (val);
+ POP2 (sym, val);
SYNC_REGISTER ();
VARIABLE_SET (scm_sym2var (sym, scm_current_module_lookup_closure (),
SCM_BOOL_T),
@@ -1578,8 +1586,7 @@ VM_DEFINE_INSTRUCTION (85, prompt, "prompt", 4, 2, 0)
VM_DEFINE_INSTRUCTION (86, wind, "wind", 0, 2, 0)
{
SCM wind, unwind;
- POP (unwind);
- POP (wind);
+ POP2 (unwind, wind);
SYNC_REGISTER ();
/* Push wind and unwind procedures onto the dynamic stack. Note that neither
are actually called; the compiler should emit calls to wind and unwind for
@@ -1675,8 +1682,7 @@ VM_DEFINE_INSTRUCTION (92, fluid_set, "fluid-set", 0, 2, 0)
size_t num;
SCM val, fluid, fluids;
- POP (val);
- POP (fluid);
+ POP2 (val, fluid);
fluids = SCM_I_DYNAMIC_STATE_FLUIDS (dynstate);
if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
|| ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))