diff options
author | Andy Wingo <wingo@pobox.com> | 2011-05-05 14:09:29 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-05-05 14:09:29 +0200 |
commit | 891a1851a1e0e47560cf99cf76e9478d77e1a7db (patch) | |
tree | 8d00ba1b7f14b75005285d86abba3ea05b4f1767 /libguile | |
parent | 1903eae4c9ab97b575dad4ab1f5cf05436d84ab3 (diff) | |
parent | eae2438d2bd1d9a0e0aaa052abb8b36b2d073850 (diff) | |
download | guile-891a1851a1e0e47560cf99cf76e9478d77e1a7db.tar.gz |
Merge remote-tracking branch 'origin/stable-2.0'
Diffstat (limited to 'libguile')
-rw-r--r-- | libguile/Makefile.am | 13 | ||||
-rw-r--r-- | libguile/deprecated.c | 113 | ||||
-rw-r--r-- | libguile/deprecated.h | 31 | ||||
-rw-r--r-- | libguile/eval.c | 85 | ||||
-rw-r--r-- | libguile/gc.c | 37 | ||||
-rw-r--r-- | libguile/gen-scmconfig.c | 9 | ||||
-rw-r--r-- | libguile/gen-scmconfig.h.in | 3 | ||||
-rw-r--r-- | libguile/goops.c | 73 | ||||
-rw-r--r-- | libguile/goops.h | 4 | ||||
-rw-r--r-- | libguile/hashtab.c | 78 | ||||
-rw-r--r-- | libguile/objprop.c | 18 | ||||
-rw-r--r-- | libguile/read.c | 68 | ||||
-rw-r--r-- | libguile/srcprop.c | 38 | ||||
-rw-r--r-- | libguile/srcprop.h | 26 | ||||
-rw-r--r-- | libguile/srfi-1.c | 37 | ||||
-rw-r--r-- | libguile/srfi-1.h | 3 | ||||
-rw-r--r-- | libguile/stime.c | 244 | ||||
-rw-r--r-- | libguile/stime.h | 28 | ||||
-rw-r--r-- | libguile/struct.c | 26 | ||||
-rw-r--r-- | libguile/struct.h | 9 | ||||
-rw-r--r-- | libguile/vm-engine.c | 47 | ||||
-rw-r--r-- | libguile/vm-engine.h | 26 | ||||
-rw-r--r-- | libguile/vm-i-loader.c | 3 | ||||
-rw-r--r-- | libguile/vm-i-scheme.c | 22 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 52 |
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))) |