From 86d31dfe7d0754b863863f6544c75097ef68fe8c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 15 May 2001 14:57:22 +0000 Subject: [PATCH] Merge from mvo-vcell-cleanup-1-branch. --- libguile/Makefile.am | 29 +- libguile/__scm.h | 9 + libguile/_scm.h | 2 + libguile/backtrace.c | 13 +- libguile/backtrace.h | 2 +- libguile/cpp_cnvt.awk | 2 +- libguile/debug.c | 48 ++- libguile/deprecation.c | 4 +- libguile/dynwind.c | 3 +- libguile/eval.c | 207 +++++------ libguile/eval.h | 14 +- libguile/evalext.c | 25 +- libguile/feature.c | 10 +- libguile/filesys.c | 38 +- libguile/fports.c | 6 +- libguile/gc.c | 102 ++---- libguile/gdbint.c | 6 +- libguile/gh_data.c | 8 +- libguile/gh_funcs.c | 3 +- libguile/goops.c | 13 +- libguile/gsubr.c | 8 +- libguile/hooks.c | 2 +- libguile/init.c | 5 +- libguile/keywords.c | 13 +- libguile/load.c | 12 +- libguile/macros.c | 6 +- libguile/modules.c | 339 +++++++++++++++--- libguile/modules.h | 23 +- libguile/numbers.c | 6 +- libguile/objects.c | 6 +- libguile/ports.c | 6 +- libguile/posix.c | 46 +-- libguile/print.c | 3 +- libguile/procs.c | 17 +- libguile/ramap.c | 11 +- libguile/random.c | 18 +- libguile/read.c | 2 +- libguile/regex-posix.c | 12 +- libguile/root.h | 22 +- libguile/scmsigs.c | 14 +- libguile/script.c | 2 +- libguile/snarf.h | 26 +- libguile/socket.c | 72 ++-- libguile/srcprop.c | 2 +- libguile/stacks.c | 6 +- libguile/stime.c | 2 +- libguile/struct.c | 9 +- libguile/symbols-deprecated.c | 637 ++++++++++++++++++++++++++++++++++ libguile/symbols.c | 629 +++------------------------------ libguile/symbols.h | 51 +-- libguile/tag.c | 108 ------ libguile/throw.c | 4 +- libguile/variable.c | 136 +++----- libguile/variable.h | 30 +- 54 files changed, 1537 insertions(+), 1292 deletions(-) create mode 100644 libguile/symbols-deprecated.c rewrite libguile/tag.c (100%) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index caa46ff15..1931d2dc9 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -49,7 +49,7 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ random.c rdelim.c read.c root.c rw.c scmsigs.c script.c simpos.c smob.c \ sort.c srcprop.c stackchk.c stacks.c stime.c strings.c strop.c \ strorder.c strports.c struct.c symbols.c tag.c throw.c values.c \ - variable.c vectors.c version.c vports.c weaks.c + variable.c vectors.c version.c vports.c weaks.c symbols-deprecated.c DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ continuations.x debug.x deprecation.x dynl.x dynwind.x \ @@ -62,23 +62,24 @@ DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ scmsigs.x script.x simpos.x smob.x sort.x srcprop.x \ stackchk.x stacks.x stime.x strings.x strop.x strorder.x strports.x \ struct.x symbols.x tag.x throw.x values.x variable.x vectors.x \ - version.x vports.x weaks.x + version.x vports.x weaks.x symbols-deprecated.x EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@ -DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ - boolean.doc chars.doc continuations.doc debug.doc dynl.doc \ - dynwind.doc environments.doc eq.doc error.doc eval.doc evalext.doc \ - feature.doc fluids.doc fports.doc gc.doc goops.doc gsubr.doc \ - guardians.doc hash.doc hashtab.doc hooks.doc init.doc ioext.doc \ - iselect.doc keywords.doc lang.doc list.doc load.doc macros.doc \ - mallocs.doc modules.doc numbers.doc objects.doc objprop.doc \ - options.doc pairs.doc ports.doc print.doc procprop.doc \ +DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ + boolean.doc chars.doc continuations.doc debug.doc dynl.doc \ + dynwind.doc environments.doc eq.doc error.doc eval.doc evalext.doc \ + feature.doc fluids.doc fports.doc gc.doc goops.doc gsubr.doc \ + guardians.doc hash.doc hashtab.doc hooks.doc init.doc ioext.doc \ + iselect.doc keywords.doc lang.doc list.doc load.doc macros.doc \ + mallocs.doc modules.doc numbers.doc objects.doc objprop.doc \ + options.doc pairs.doc ports.doc print.doc procprop.doc \ procs.doc properties.doc random.doc rdelim.doc read.doc root.doc rw.doc \ - scmsigs.doc script.doc simpos.doc smob.doc sort.doc \ - srcprop.doc stackchk.doc stacks.doc stime.doc strings.doc strop.doc \ - strorder.doc strports.doc struct.doc symbols.doc tag.doc throw.doc \ - values.doc variable.doc vectors.doc version.doc vports.doc weaks.doc + scmsigs.doc script.doc simpos.doc smob.doc sort.doc \ + srcprop.doc stackchk.doc stacks.doc stime.doc strings.doc strop.doc \ + strorder.doc strports.doc struct.doc symbols.doc tag.doc throw.doc \ + values.doc variable.doc vectors.doc version.doc vports.doc weaks.doc \ + symbols-deprecated.doc EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@ diff --git a/libguile/__scm.h b/libguile/__scm.h index 8fe7c3b56..9e0fea279 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -195,6 +195,15 @@ #define SCM_DEBUG_TYPING_STRICTNESS 0 #endif +/* If SCM_ENABLE_VCELLS is set to 1, a couple of functions that deal + * with vcells are defined for compatability reasons. Supporting + * vcells reduces performance however. + * + * We use a dedicated macro instead of just SCM_DEBUG_DEPRECATED so + * that code the belongs to the `vcell' feature is easier to find. + */ +#define SCM_ENABLE_VCELLS !SCM_DEBUG_DEPRECATED + #ifdef HAVE_LONG_LONGS diff --git a/libguile/_scm.h b/libguile/_scm.h index 3ffdc64c4..ec9839d80 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -75,6 +75,8 @@ switching at async ticks. */ #endif #include "libguile/snarf.h" /* Everyone snarfs. */ +#include "libguile/variable.h" +#include "libguile/modules.h" /* SCM_SYSCALL retries system calls that have been interrupted (EINTR). However this can be avoided if the operating system can restart diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 4d2534ad3..95fb71cd0 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -80,7 +80,7 @@ return SCM_BOOL_F; #endif -SCM scm_the_last_stack_fluid; +SCM scm_the_last_stack_fluid_var; static void display_header (SCM source, SCM port) @@ -634,7 +634,7 @@ SCM_DEFINE (scm_display_backtrace, "display-backtrace", 2, 2, 0, } #undef FUNC_NAME -SCM_VCELL (scm_has_shown_backtrace_hint_p_var, "has-shown-backtrace-hint?"); +SCM_VARIABLE (scm_has_shown_backtrace_hint_p_var, "has-shown-backtrace-hint?"); SCM_DEFINE (scm_backtrace, "backtrace", 0, 0, 0, (), @@ -642,7 +642,8 @@ SCM_DEFINE (scm_backtrace, "backtrace", 0, 0, 0, "to the current output port.") #define FUNC_NAME s_scm_backtrace { - SCM the_last_stack = scm_fluid_ref (SCM_CDR (scm_the_last_stack_fluid)); + SCM the_last_stack = + scm_fluid_ref (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var)); if (SCM_NFALSEP (the_last_stack)) { scm_newline (scm_cur_outp); @@ -652,14 +653,14 @@ SCM_DEFINE (scm_backtrace, "backtrace", 0, 0, 0, SCM_UNDEFINED, SCM_UNDEFINED); scm_newline (scm_cur_outp); - if (SCM_FALSEP (SCM_CDR (scm_has_shown_backtrace_hint_p_var)) + if (SCM_FALSEP (SCM_VARIABLE_REF (scm_has_shown_backtrace_hint_p_var)) && !SCM_BACKTRACE_P) { scm_puts ("Type \"(debug-enable 'backtrace)\" if you would like " "a backtrace\n" "automatically if an error occurs in the future.\n", scm_cur_outp); - SCM_SETCDR (scm_has_shown_backtrace_hint_p_var, SCM_BOOL_T); + SCM_VARIABLE_SET (scm_has_shown_backtrace_hint_p_var, SCM_BOOL_T); } } else @@ -676,7 +677,7 @@ void scm_init_backtrace () { SCM f = scm_make_fluid (); - scm_the_last_stack_fluid = scm_sysintern ("the-last-stack", f); + scm_the_last_stack_fluid_var = scm_c_define ("the-last-stack", f); #ifndef SCM_MAGIC_SNARFER #include "libguile/backtrace.x" diff --git a/libguile/backtrace.h b/libguile/backtrace.h index 68f85a2c7..0bc8c0803 100644 --- a/libguile/backtrace.h +++ b/libguile/backtrace.h @@ -49,7 +49,7 @@ #include "libguile/__scm.h" -extern SCM scm_the_last_stack_fluid; +extern SCM scm_the_last_stack_fluid_var; void scm_display_error_message (SCM message, SCM args, SCM port); void scm_i_display_error (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest); diff --git a/libguile/cpp_cnvt.awk b/libguile/cpp_cnvt.awk index a01ba52a8..128136fa2 100644 --- a/libguile/cpp_cnvt.awk +++ b/libguile/cpp_cnvt.awk @@ -2,6 +2,6 @@ # in Guile. { print "#ifdef " $0; -print "scm_sysintern (\""$0"\", SCM_MAKINUM ("$0"));"; +print "scm_c_define (\""$0"\", SCM_MAKINUM ("$0"));"; print "#endif" } diff --git a/libguile/debug.c b/libguile/debug.c index 42981bfe7..c5e7468db 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -260,17 +260,12 @@ SCM_DEFINE (scm_make_gloc, "make-gloc", 1, 1, 0, "@var{env}.") #define FUNC_NAME s_scm_make_gloc { -#if 1 /* Unsafe */ - if (SCM_CONSP (var)) - var = scm_cons (SCM_BOOL_F, var); - else -#endif - SCM_VALIDATE_VARIABLE (1,var); + SCM_VALIDATE_VARIABLE (1,var); if (SCM_UNBNDP (env)) env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE); else SCM_VALIDATE_NULLORCONS (2,env); - return scm_make_memoized (SCM_VARVCELL (var) + 1, env); + return scm_make_memoized (SCM_UNPACK (var) + scm_tc3_cons_gloc, env); } #undef FUNC_NAME @@ -279,8 +274,9 @@ SCM_DEFINE (scm_gloc_p, "gloc?", 1, 0, 0, "Return @code{#t} if @var{obj} is a gloc.") #define FUNC_NAME s_scm_gloc_p { - return SCM_BOOL((SCM_MEMOIZEDP (obj) - && (SCM_UNPACK(SCM_MEMOIZED_EXP (obj)) & 7) == 1)); + return + SCM_BOOL (SCM_MEMOIZEDP (obj) + && ((SCM_UNPACK(SCM_MEMOIZED_EXP(obj))&7) == scm_tc3_cons_gloc)); } #undef FUNC_NAME @@ -623,23 +619,23 @@ scm_init_debug () scm_set_smob_print (scm_tc16_debugobj, debugobj_print); #ifdef GUILE_DEBUG - scm_sysintern ("SCM_IM_AND", SCM_IM_AND); - scm_sysintern ("SCM_IM_BEGIN", SCM_IM_BEGIN); - scm_sysintern ("SCM_IM_CASE", SCM_IM_CASE); - scm_sysintern ("SCM_IM_COND", SCM_IM_COND); - scm_sysintern ("SCM_IM_DO", SCM_IM_DO); - scm_sysintern ("SCM_IM_IF", SCM_IM_IF); - scm_sysintern ("SCM_IM_LAMBDA", SCM_IM_LAMBDA); - scm_sysintern ("SCM_IM_LET", SCM_IM_LET); - scm_sysintern ("SCM_IM_LETSTAR", SCM_IM_LETSTAR); - scm_sysintern ("SCM_IM_LETREC", SCM_IM_LETREC); - scm_sysintern ("SCM_IM_OR", SCM_IM_OR); - scm_sysintern ("SCM_IM_QUOTE", SCM_IM_QUOTE); - scm_sysintern ("SCM_IM_SET_X", SCM_IM_SET_X); - scm_sysintern ("SCM_IM_DEFINE", SCM_IM_DEFINE); - scm_sysintern ("SCM_IM_APPLY", SCM_IM_APPLY); - scm_sysintern ("SCM_IM_CONT", SCM_IM_CONT); - scm_sysintern ("SCM_IM_DISPATCH", SCM_IM_DISPATCH); + scm_define ("SCM_IM_AND", SCM_IM_AND); + scm_define ("SCM_IM_BEGIN", SCM_IM_BEGIN); + scm_define ("SCM_IM_CASE", SCM_IM_CASE); + scm_define ("SCM_IM_COND", SCM_IM_COND); + scm_define ("SCM_IM_DO", SCM_IM_DO); + scm_define ("SCM_IM_IF", SCM_IM_IF); + scm_define ("SCM_IM_LAMBDA", SCM_IM_LAMBDA); + scm_define ("SCM_IM_LET", SCM_IM_LET); + scm_define ("SCM_IM_LETSTAR", SCM_IM_LETSTAR); + scm_define ("SCM_IM_LETREC", SCM_IM_LETREC); + scm_define ("SCM_IM_OR", SCM_IM_OR); + scm_define ("SCM_IM_QUOTE", SCM_IM_QUOTE); + scm_define ("SCM_IM_SET_X", SCM_IM_SET_X); + scm_define ("SCM_IM_DEFINE", SCM_IM_DEFINE); + scm_define ("SCM_IM_APPLY", SCM_IM_APPLY); + scm_define ("SCM_IM_CONT", SCM_IM_CONT); + scm_define ("SCM_IM_DISPATCH", SCM_IM_DISPATCH); #endif scm_add_feature ("debug-extensions"); diff --git a/libguile/deprecation.c b/libguile/deprecation.c index a8e2e6cab..b826f190e 100644 --- a/libguile/deprecation.c +++ b/libguile/deprecation.c @@ -116,8 +116,8 @@ print_deprecation_summary (void) SCM_DEFINE(scm_include_deprecated_features, "include-deprecated-features", 0, 0, 0, (), - "Return @code{#t} iff deprecated features should be included\n" - "in public interfaces.") + "Return @code{#t} iff deprecated features should be included + in public interfaces.") #define FUNC_NAME s_scm_include_deprecated_features { #if SCM_DEBUG_DEPRECATED == 0 diff --git a/libguile/dynwind.c b/libguile/dynwind.c index c79097b61..54323a568 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -193,8 +193,7 @@ scm_swap_bindings (SCM glocs, SCM vals) while (SCM_NIMP (vals)) { tmp = SCM_GLOC_VAL (SCM_CAR (glocs)); - SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (glocs)) - 1L), - SCM_CAR (vals)); + SCM_GLOC_SET_VAL (SCM_CAR (glocs), SCM_CAR (vals)); SCM_SETCAR (vals, tmp); glocs = SCM_CDR (glocs); vals = SCM_CDR (vals); diff --git a/libguile/eval.c b/libguile/eval.c index a4fea7d63..5d8185c9f 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -52,7 +52,6 @@ * marked with the string "SECTION:". */ - /* SECTION: This code is compiled once. */ @@ -265,9 +264,6 @@ scm_lookupcar (SCM vloc, SCM genv, int check) { SCM env = genv; register SCM *al, fl, var = SCM_CAR (vloc); -#ifdef USE_THREADS - register SCM var2 = var; -#endif #ifdef MEMOIZE_LOCALS register SCM iloc = SCM_ILOC00; #endif @@ -322,69 +318,70 @@ scm_lookupcar (SCM vloc, SCM genv, int check) #endif } { - SCM top_thunk, vcell; + SCM top_thunk, real_var; if (SCM_NIMP (env)) { - top_thunk = SCM_CAR (env); /* env now refers to a top level env thunk */ + top_thunk = SCM_CAR (env); /* env now refers to a + top level env thunk */ env = SCM_CDR (env); } else top_thunk = SCM_BOOL_F; - vcell = scm_sym2vcell (var, top_thunk, SCM_BOOL_F); - if (SCM_FALSEP (vcell)) + real_var = scm_sym2var (var, top_thunk, SCM_BOOL_F); + if (SCM_FALSEP (real_var)) goto errout; - else - var = vcell; - } + #ifndef SCM_RECKLESS - if (SCM_NNULLP (env) || SCM_UNBNDP (SCM_CDR (var))) - { - var = SCM_CAR (var); - errout: - /* scm_everr (vloc, genv,...) */ - if (check) - { - if (SCM_NULLP (env)) - scm_error (scm_unbound_variable_key, NULL, "Unbound variable: ~S", - scm_cons (var, SCM_EOL), SCM_BOOL_F); - else - scm_misc_error (NULL, "Damaged environment: ~S", - scm_cons (var, SCM_EOL)); - } - else { - /* A variable could not be found, but we shall not throw an error. */ - static SCM undef_object = SCM_UNDEFINED; - return &undef_object; + if (SCM_NNULLP (env) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var))) + { + errout: + /* scm_everr (vloc, genv,...) */ + if (check) + { + if (SCM_NULLP (env)) + scm_error (scm_unbound_variable_key, NULL, + "Unbound variable: ~S", + scm_cons (var, SCM_EOL), SCM_BOOL_F); + else + scm_misc_error (NULL, "Damaged environment: ~S", + scm_cons (var, SCM_EOL)); + } + else + { + /* A variable could not be found, but we shall + not throw an error. */ + static SCM undef_object = SCM_UNDEFINED; + return &undef_object; + } } - } #endif + #ifdef USE_THREADS - if (SCM_CAR (vloc) != var2) - { - /* Some other thread has changed the very cell we are working - on. In effect, it must have done our job or messed it up - completely. */ - race: - var = SCM_CAR (vloc); - if (SCM_ITAG3 (var) == scm_tc3_cons_gloc) - return SCM_GLOC_VAL_LOC (var); + if (SCM_CAR (vloc) != var) + { + /* Some other thread has changed the very cell we are working + on. In effect, it must have done our job or messed it up + completely. */ + race: + var = SCM_CAR (vloc); + if (SCM_ITAG3 (var) == scm_tc3_cons_gloc) + return SCM_GLOC_VAL_LOC (var); #ifdef MEMOIZE_LOCALS - if (SCM_ITAG7 (var) == SCM_ITAG7 (SCM_ILOC00)) - return scm_ilookup (var, genv); + if (SCM_ITAG7 (var) == SCM_ITAG7 (SCM_ILOC00)) + return scm_ilookup (var, genv); #endif - /* We can't cope with anything else than glocs and ilocs. When - a special form has been memoized (i.e. `let' into `#@let') we - return NULL and expect the calling function to do the right - thing. For the evaluator, this means going back and redoing - the dispatch on the car of the form. */ - return NULL; - } + /* We can't cope with anything else than glocs and ilocs. When + a special form has been memoized (i.e. `let' into `#@let') we + return NULL and expect the calling function to do the right + thing. For the evaluator, this means going back and redoing + the dispatch on the car of the form. */ + return NULL; + } #endif /* USE_THREADS */ - SCM_SET_CELL_WORD_0 (vloc, SCM_UNPACK (var) + scm_tc3_cons_gloc); - /* Except wait...what if the var is not a vcell, - * but syntax or something.... */ - return SCM_CDRLOC (var); + SCM_SET_CELL_WORD_0 (vloc, SCM_UNPACK (real_var) + scm_tc3_cons_gloc); + return SCM_VARIABLE_LOC (real_var); + } } #ifdef USE_THREADS @@ -400,6 +397,8 @@ scm_lookupcar (SCM vloc, SCM genv, int check) #define unmemocar scm_unmemocar +SCM_SYMBOL (sym_three_question_marks, "???"); + SCM scm_unmemocar (SCM form, SCM env) { @@ -409,7 +408,13 @@ scm_unmemocar (SCM form, SCM env) return form; c = SCM_CAR (form); if (SCM_ITAG3 (c) == scm_tc3_cons_gloc) - SCM_SETCAR (form, SCM_GLOC_SYM (c)); + { + SCM sym = + scm_module_reverse_lookup (scm_env_module (env), SCM_GLOC_VAR (c)); + if (sym == SCM_BOOL_F) + sym = sym_three_question_marks; + SCM_SETCAR (form, sym); + } #ifdef MEMOIZE_LOCALS #ifdef DEBUG_EXTENSIONS else if (SCM_ILOCP (c)) @@ -885,10 +890,10 @@ scm_m_define (SCM x, SCM env) } } #endif - arg1 = scm_sym2vcell (proc, scm_env_top_level (env), SCM_BOOL_T); - SCM_SETCDR (arg1, x); + arg1 = scm_sym2var (proc, scm_env_top_level (env), SCM_BOOL_T); + SCM_VARIABLE_SET (arg1, x); #ifdef SICP - return scm_cons2 (scm_sym_quote, SCM_CAR (arg1), SCM_EOL); + return scm_cons2 (scm_sym_quote, proc, SCM_EOL); #else return SCM_UNSPECIFIED; #endif @@ -1030,8 +1035,8 @@ scm_m_cont (SCM xorig, SCM env) /* Multi-language support */ -SCM scm_lisp_nil; -SCM scm_lisp_t; +SCM_GLOBAL_SYMBOL (scm_lisp_nil, "nil"); +SCM_GLOBAL_SYMBOL (scm_lisp_t, "t"); SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond); @@ -1094,12 +1099,12 @@ SCM_SYNTAX (s_atfop, "@fop", scm_makmmacro, scm_m_atfop); SCM scm_m_atfop (SCM xorig, SCM env) { - SCM x = SCM_CDR (xorig), vcell; + SCM x = SCM_CDR (xorig), var; SCM_ASSYNT (scm_ilength (x) >= 1, scm_s_expression, "@fop"); - vcell = scm_symbol_fref (SCM_CAR (x)); - SCM_ASSYNT (SCM_CONSP (vcell), + var = scm_symbol_fref (SCM_CAR (x)); + SCM_ASSYNT (SCM_VARIABLEP (var), "Symbol's function definition is void", NULL); - SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (vcell) + scm_tc3_cons_gloc); + SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (var) + scm_tc3_cons_gloc); return x; } @@ -1125,7 +1130,7 @@ scm_m_atbind (SCM xorig, SCM env) x = SCM_CAR (x); while (SCM_NIMP (x)) { - SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (scm_sym2vcell (SCM_CAR (x), env, SCM_BOOL_T)) + scm_tc3_cons_gloc); + SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (scm_sym2var (SCM_CAR (x), env, SCM_BOOL_T)) + scm_tc3_cons_gloc); x = SCM_CDR (x); } return scm_cons (SCM_IM_BIND, SCM_CDR (xorig)); @@ -1202,13 +1207,14 @@ scm_m_expand_body (SCM xorig, SCM env) SCM scm_macroexp (SCM x, SCM env) { - SCM res, proc; + SCM res, proc, orig_sym; /* Don't bother to produce error messages here. We get them when we eventually execute the code for real. */ macro_tail: - if (!SCM_SYMBOLP (SCM_CAR (x))) + orig_sym = SCM_CAR (x); + if (!SCM_SYMBOLP (orig_sym)) return x; #ifdef USE_THREADS @@ -1231,7 +1237,7 @@ scm_macroexp (SCM x, SCM env) if (!SCM_MACROP (proc) || SCM_MACRO_TYPE (proc) != 2) return x; - unmemocar (x, env); + SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */ res = scm_apply (SCM_MACRO_CODE (proc), x, scm_cons (env, scm_listofnull)); if (scm_ilength (res) <= 0) @@ -1252,13 +1258,12 @@ scm_macroexp (SCM x, SCM env) * code of a closure, in scm_procedure_source, in display_frame when * generating the source for a stackframe in a backtrace, and in * display_expression. - */ - -/* We should introduce an anti-macro interface so that it is possible - * to plug in transformers in both directions from other compilation - * units. unmemocopy could then dispatch to anti-macro transformers. - * (Those transformers could perhaps be written in slightly more - * readable style... :) + * + * Unmemoizing is not a realiable process. You can not in general + * expect to get the original source back. + * + * However, GOOPS currently relies on this for method compilation. + * This ought to change. */ #define SCM_BIT8(x) (127 & SCM_UNPACK (x)) @@ -1519,11 +1524,12 @@ scm_eval_args (SCM l, SCM env, SCM proc) } else if (SCM_TYP3 (l) == scm_tc3_cons_gloc) { - scm_bits_t vcell = SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell]; + scm_bits_t vcell = + SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell]; if (vcell == 0) res = SCM_CAR (l); /* struct planted in code */ else - res = SCM_PACK (vcell); + res = SCM_GLOC_VAL (SCM_CAR (l)); } else goto wrongnumargs; @@ -1742,11 +1748,12 @@ scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc) } else if (SCM_TYP3 (l) == scm_tc3_cons_gloc) { - scm_bits_t vcell = SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell]; + scm_bits_t vcell = + SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell]; if (vcell == 0) res = SCM_CAR (l); /* struct planted in code */ else - res = SCM_PACK (vcell); + res = SCM_GLOC_VAL (SCM_CAR (l)); } else goto wrongnumargs; @@ -1814,7 +1821,7 @@ SCM_CEVAL (SCM x, SCM env) SCM *lloc; SCM arg1; } t; - SCM proc, arg2; + SCM proc, arg2, orig_sym; #ifdef DEVAL scm_debug_frame debug; scm_debug_info *debug_info_end; @@ -2542,7 +2549,7 @@ dispatch: /* This is a struct implanted in the code, not a gloc. */ RETURN (x); } else { - proc = SCM_PACK (vcell); + proc = SCM_GLOC_VAL (SCM_CAR (x)); SCM_ASRTGO (SCM_NIMP (proc), badfun); #ifndef SCM_RECKLESS #ifdef SCM_CAUTIOUS @@ -2554,7 +2561,8 @@ dispatch: } case scm_tcs_cons_nimcar: - if (SCM_SYMBOLP (SCM_CAR (x))) + orig_sym = SCM_CAR (x); + if (SCM_SYMBOLP (orig_sym)) { #ifdef USE_THREADS t.lloc = scm_lookupcar1 (x, env, 1); @@ -2570,13 +2578,14 @@ dispatch: if (SCM_IMP (proc)) { - unmemocar (x, env); + SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of + lookupcar */ goto badfun; } if (SCM_MACROP (proc)) { - unmemocar (x, env); - + SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of + lookupcar */ handle_a_macro: #ifdef DEVAL /* Set a flag during macro expansion so that macro @@ -2692,7 +2701,7 @@ evapply: x = SCM_CODE (proc); env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), SCM_EOL, SCM_ENV (proc)); goto nontoplevel_cdrxbegin; - case scm_tcs_cons_gloc: + case scm_tcs_cons_gloc: /* really structs, not glocs */ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { x = SCM_ENTITY_PROCEDURE (proc); @@ -2751,7 +2760,7 @@ evapply: if (vcell == 0) t.arg1 = SCM_CAR (x); /* struct planted in code */ else - t.arg1 = SCM_PACK (vcell); + t.arg1 = SCM_GLOC_VAL (SCM_CAR (x)); } else goto wrongnumargs; @@ -2847,7 +2856,7 @@ evapply: env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc)); #endif goto nontoplevel_cdrxbegin; - case scm_tcs_cons_gloc: + case scm_tcs_cons_gloc: /* really structs, not glocs */ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { x = SCM_ENTITY_PROCEDURE (proc); @@ -2901,7 +2910,7 @@ evapply: if (vcell == 0) arg2 = SCM_CAR (x); /* struct planted in code */ else - arg2 = SCM_PACK (vcell); + arg2 = SCM_GLOC_VAL (SCM_CAR (x)); } else goto wrongnumargs; @@ -2951,7 +2960,7 @@ evapply: proc))), SCM_EOL)); #endif - case scm_tcs_cons_gloc: + case scm_tcs_cons_gloc: /* really structs, not glocs */ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { x = SCM_ENTITY_PROCEDURE (proc); @@ -3165,7 +3174,7 @@ evapply: x = SCM_CODE (proc); goto nontoplevel_cdrxbegin; #endif /* DEVAL */ - case scm_tcs_cons_gloc: + case scm_tcs_cons_gloc: /* really structs, not glocs */ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { #ifdef DEVAL @@ -3541,7 +3550,7 @@ tail: debug.vect[0].a.proc = proc; #endif goto tail; - case scm_tcs_cons_gloc: + case scm_tcs_cons_gloc: /* really structs, not glocs */ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { #ifdef DEVAL @@ -3752,6 +3761,7 @@ SCM scm_closure (SCM code, SCM env) { register SCM z; + SCM_NEWCELL (z); SCM_SETCODE (z, code); SCM_SETENV (z, env); @@ -4090,24 +4100,23 @@ scm_init_eval () scm_f_apply = scm_make_subr ("apply", scm_tc7_lsubr_2, scm_apply); - scm_lisp_nil = scm_sysintern ("nil", SCM_UNDEFINED); - SCM_SETCDR (scm_lisp_nil, SCM_CAR (scm_lisp_nil)); - scm_lisp_nil = SCM_CAR (scm_lisp_nil); - scm_lisp_t = scm_sysintern ("t", SCM_UNDEFINED); - SCM_SETCDR (scm_lisp_t, SCM_CAR (scm_lisp_t)); - scm_lisp_t = SCM_CAR (scm_lisp_t); - + /* acros */ + /* end of acros */ + #if SCM_DEBUG_DEPRECATED == 0 scm_top_level_lookup_closure_var = - scm_sysintern ("*top-level-lookup-closure*", scm_make_fluid ()); + scm_c_define ("*top-level-lookup-closure*", scm_make_fluid ()); scm_system_transformer = - scm_sysintern ("scm:eval-transformer", scm_make_fluid ()); + scm_c_define ("scm:eval-transformer", scm_make_fluid ()); #endif #ifndef SCM_MAGIC_SNARFER #include "libguile/eval.x" #endif + scm_c_define ("nil", scm_lisp_nil); + scm_c_define ("t", scm_lisp_t); + scm_add_feature ("delay"); } diff --git a/libguile/eval.h b/libguile/eval.h index aee3a399d..80e0e5faa 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -46,8 +46,6 @@ #include "libguile/__scm.h" -/* Needed by SCM_TOP_LEVEL_LOOKUP_CLOSURE below. */ - #include "struct.h" @@ -131,8 +129,7 @@ extern SCM scm_eval_options_interface (SCM setting); /*fixme* This should probably be removed throught the code. */ -#define SCM_TOP_LEVEL_LOOKUP_CLOSURE \ - SCM_MODULE_EVAL_CLOSURE (scm_current_module ()) +#define SCM_TOP_LEVEL_LOOKUP_CLOSURE (scm_current_module_lookup_closure()) #if SCM_DEBUG_DEPRECATED == 0 @@ -181,13 +178,14 @@ extern SCM scm_sym_args; extern SCM scm_f_apply; /* A resolved global variable reference in the CAR position - * of a list is stored (in code only) as a pointer to a pair with a + * of a list is stored (in code only) as a pointer to a variable with a * tag of 1. This is called a "gloc". */ -#define SCM_GLOC_SYM(x) (SCM_CAR (SCM_PACK (SCM_UNPACK (x) - 1L))) -#define SCM_GLOC_VAL(x) (SCM_CDR (SCM_PACK (SCM_UNPACK (x) - 1L))) -#define SCM_GLOC_VAL_LOC(x) (SCM_CDRLOC (SCM_PACK (SCM_UNPACK (x) - 1L))) +#define SCM_GLOC_VAR(x) (SCM_PACK(SCM_UNPACK(x)-scm_tc3_cons_gloc)) +#define SCM_GLOC_VAL(x) (SCM_VARIABLE_REF (SCM_GLOC_VAR (x))) +#define SCM_GLOC_SET_VAL(x, y) (SCM_VARIABLE_SET (SCM_GLOC_VAR (x), y)) +#define SCM_GLOC_VAL_LOC(x) (SCM_VARIABLE_LOC (SCM_GLOC_VAR (x))) diff --git a/libguile/evalext.c b/libguile/evalext.c index 1cbac13f7..a36ef687b 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -77,16 +77,13 @@ SCM_DEFINE (scm_definedp, "defined?", 1, 1, 0, "current module.") #define FUNC_NAME s_scm_definedp { - SCM vcell; + SCM var; SCM_VALIDATE_SYMBOL (1,sym); if (SCM_UNBNDP (env)) - vcell = scm_sym2vcell(sym, - scm_module_system_booted_p - ? SCM_TOP_LEVEL_LOOKUP_CLOSURE - : SCM_EOL, - SCM_BOOL_F); + var = scm_sym2var (sym, scm_current_module_lookup_closure (), + SCM_BOOL_F); else { SCM frames = env; @@ -111,12 +108,12 @@ SCM_DEFINE (scm_definedp, "defined?", 1, 1, 0, return SCM_BOOL_T; } } - vcell = scm_sym2vcell (sym, - SCM_NIMP (frames) ? SCM_CAR (frames) : SCM_BOOL_F, - SCM_BOOL_F); + var = scm_sym2var (sym, + SCM_NIMP (frames) ? SCM_CAR (frames) : SCM_BOOL_F, + SCM_BOOL_F); } - return (SCM_FALSEP (vcell) || SCM_UNBNDP (SCM_CDR (vcell)) + return (SCM_FALSEP (var) || SCM_UNBNDP (SCM_VARIABLE_REF (var)) ? SCM_BOOL_F : SCM_BOOL_T); } @@ -135,12 +132,12 @@ scm_m_undefine (SCM x, SCM env) scm_s_expression, s_undefine); x = SCM_CAR (x); SCM_ASSYNT (SCM_SYMBOLP (x), scm_s_variable, s_undefine); - arg1 = scm_sym2vcell (x, scm_env_top_level (env), SCM_BOOL_F); - SCM_ASSYNT (SCM_NFALSEP (arg1) && !SCM_UNBNDP (SCM_CDR (arg1)), + arg1 = scm_sym2var (x, scm_env_top_level (env), SCM_BOOL_F); + SCM_ASSYNT (SCM_NFALSEP (arg1) && !SCM_UNBNDP (SCM_VARIABLE_REF (arg1)), "variable already unbound ", s_undefine); - SCM_SETCDR (arg1, SCM_UNDEFINED); + SCM_VARIABLE_SET (arg1, SCM_UNDEFINED); #ifdef SICP - return SCM_CAR (arg1); + return x; #else return SCM_UNSPECIFIED; #endif diff --git a/libguile/feature.c b/libguile/feature.c index d37b83ce9..43073e91d 100644 --- a/libguile/feature.c +++ b/libguile/feature.c @@ -57,15 +57,15 @@ -static SCM features; +static SCM features_var; void scm_add_feature (const char *str) { - SCM old = SCM_CDR (features); + SCM old = SCM_VARIABLE_REF (features_var); SCM new = scm_cons (scm_str2symbol (str), old); - SCM_SETCDR (features, new); + SCM_VARIABLE_SET (features_var, new); } @@ -103,7 +103,7 @@ scm_set_program_arguments (int argc, char **argv, char *first) void scm_init_feature() { - features = scm_sysintern ("*features*", SCM_EOL); + features_var = scm_c_define ("*features*", SCM_EOL); #ifdef SCM_RECKLESS scm_add_feature("reckless"); #endif @@ -126,7 +126,7 @@ scm_init_feature() scm_add_feature ("threads"); #endif - scm_sysintern ("char-code-limit", SCM_MAKINUM (SCM_CHAR_CODE_LIMIT)); + scm_c_define ("char-code-limit", SCM_MAKINUM (SCM_CHAR_CODE_LIMIT)); #ifndef SCM_MAGIC_SNARFER #include "libguile/feature.x" diff --git a/libguile/filesys.c b/libguile/filesys.c index 81b7522a7..e48d37764 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1440,62 +1440,62 @@ scm_init_filesys () scm_dot_string = scm_permanent_object (scm_makfrom0str (".")); #ifdef O_RDONLY -scm_sysintern ("O_RDONLY", scm_long2num (O_RDONLY)); + scm_c_define ("O_RDONLY", scm_long2num (O_RDONLY)); #endif #ifdef O_WRONLY -scm_sysintern ("O_WRONLY", scm_long2num (O_WRONLY)); + scm_c_define ("O_WRONLY", scm_long2num (O_WRONLY)); #endif #ifdef O_RDWR -scm_sysintern ("O_RDWR", scm_long2num (O_RDWR)); + scm_c_define ("O_RDWR", scm_long2num (O_RDWR)); #endif #ifdef O_CREAT -scm_sysintern ("O_CREAT", scm_long2num (O_CREAT)); + scm_c_define ("O_CREAT", scm_long2num (O_CREAT)); #endif #ifdef O_EXCL -scm_sysintern ("O_EXCL", scm_long2num (O_EXCL)); + scm_c_define ("O_EXCL", scm_long2num (O_EXCL)); #endif #ifdef O_NOCTTY -scm_sysintern ("O_NOCTTY", scm_long2num (O_NOCTTY)); + scm_c_define ("O_NOCTTY", scm_long2num (O_NOCTTY)); #endif #ifdef O_TRUNC -scm_sysintern ("O_TRUNC", scm_long2num (O_TRUNC)); + scm_c_define ("O_TRUNC", scm_long2num (O_TRUNC)); #endif #ifdef O_APPEND -scm_sysintern ("O_APPEND", scm_long2num (O_APPEND)); + scm_c_define ("O_APPEND", scm_long2num (O_APPEND)); #endif #ifdef O_NONBLOCK -scm_sysintern ("O_NONBLOCK", scm_long2num (O_NONBLOCK)); + scm_c_define ("O_NONBLOCK", scm_long2num (O_NONBLOCK)); #endif #ifdef O_NDELAY -scm_sysintern ("O_NDELAY", scm_long2num (O_NDELAY)); + scm_c_define ("O_NDELAY", scm_long2num (O_NDELAY)); #endif #ifdef O_SYNC -scm_sysintern ("O_SYNC", scm_long2num (O_SYNC)); + scm_c_define ("O_SYNC", scm_long2num (O_SYNC)); #endif #ifdef F_DUPFD -scm_sysintern ("F_DUPFD", scm_long2num (F_DUPFD)); + scm_c_define ("F_DUPFD", scm_long2num (F_DUPFD)); #endif #ifdef F_GETFD -scm_sysintern ("F_GETFD", scm_long2num (F_GETFD)); + scm_c_define ("F_GETFD", scm_long2num (F_GETFD)); #endif #ifdef F_SETFD -scm_sysintern ("F_SETFD", scm_long2num (F_SETFD)); + scm_c_define ("F_SETFD", scm_long2num (F_SETFD)); #endif #ifdef F_GETFL -scm_sysintern ("F_GETFL", scm_long2num (F_GETFL)); + scm_c_define ("F_GETFL", scm_long2num (F_GETFL)); #endif #ifdef F_SETFL -scm_sysintern ("F_SETFL", scm_long2num (F_SETFL)); + scm_c_define ("F_SETFL", scm_long2num (F_SETFL)); #endif #ifdef F_GETOWN -scm_sysintern ("F_GETOWN", scm_long2num (F_GETOWN)); + scm_c_define ("F_GETOWN", scm_long2num (F_GETOWN)); #endif #ifdef F_SETOWN -scm_sysintern ("F_SETOWN", scm_long2num (F_SETOWN)); + scm_c_define ("F_SETOWN", scm_long2num (F_SETOWN)); #endif #ifdef FD_CLOEXEC -scm_sysintern ("FD_CLOEXEC", scm_long2num (FD_CLOEXEC)); + scm_c_define ("FD_CLOEXEC", scm_long2num (FD_CLOEXEC)); #endif #ifndef SCM_MAGIC_SNARFER diff --git a/libguile/fports.c b/libguile/fports.c index 422d7d938..4579d3eb7 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -802,9 +802,9 @@ scm_init_fports () { scm_tc16_fport = scm_make_fptob (); - scm_sysintern ("_IOFBF", SCM_MAKINUM (_IOFBF)); - scm_sysintern ("_IOLBF", SCM_MAKINUM (_IOLBF)); - scm_sysintern ("_IONBF", SCM_MAKINUM (_IONBF)); + scm_c_define ("_IOFBF", SCM_MAKINUM (_IOFBF)); + scm_c_define ("_IOLBF", SCM_MAKINUM (_IOLBF)); + scm_c_define ("_IONBF", SCM_MAKINUM (_IONBF)); #ifndef SCM_MAGIC_SNARFER #include "libguile/fports.x" diff --git a/libguile/gc.c b/libguile/gc.c index ddfbbec41..d93bf1ae8 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1145,6 +1145,17 @@ MARK (SCM p) goto gc_mark_loop_first_time; #endif +/* A simple hack for debugging. Chose the second branch to get a + meaningful backtrace for crashes inside the GC. +*/ +#if 1 +#define goto_gc_mark_loop goto gc_mark_loop +#define goto_gc_mark_nimp goto gc_mark_nimp +#else +#define goto_gc_mark_loop RECURSE(ptr); return +#define goto_gc_mark_nimp RECURSE(ptr); return +#endif + gc_mark_loop: if (SCM_IMP (ptr)) return; @@ -1187,26 +1198,31 @@ gc_mark_loop_first_time: if (SCM_IMP (SCM_CDR (ptr))) { ptr = SCM_CAR (ptr); - goto gc_mark_nimp; + goto_gc_mark_nimp; } RECURSE (SCM_CAR (ptr)); ptr = SCM_CDR (ptr); - goto gc_mark_nimp; + goto_gc_mark_nimp; case scm_tcs_cons_imcar: ptr = SCM_CDR (ptr); - goto gc_mark_loop; + goto_gc_mark_loop; case scm_tc7_pws: RECURSE (SCM_SETTER (ptr)); ptr = SCM_PROCEDURE (ptr); - goto gc_mark_loop; + goto_gc_mark_loop; case scm_tcs_cons_gloc: { - /* Dirk:FIXME:: The following code is super ugly: ptr may be a struct - * or a gloc. If it is a gloc, the cell word #0 of ptr is a pointer - * to a heap cell. If it is a struct, the cell word #0 of ptr is a - * pointer to a struct vtable data region. The fact that these are - * accessed in the same way restricts the possibilites to change the - * data layout of structs or heap cells. + /* Dirk:FIXME:: The following code is super ugly: ptr may be a + * struct or a gloc. If it is a gloc, the cell word #0 of ptr + * is the address of a scm_tc16_variable smob. If it is a + * struct, the cell word #0 of ptr is a pointer to a struct + * vtable data region. (The fact that these are accessed in + * the same way restricts the possibilites to change the data + * layout of structs or heap cells.) To discriminate between + * the two, it is guaranteed that the scm_vtable_index_vcell + * element of the prospective vtable is always zero. For a + * gloc, this location has the CDR of the variable smob, which + * is guaranteed to be non-zero. */ scm_bits_t word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_cons_gloc; scm_bits_t * vtable_data = (scm_bits_t *) word0; /* access as struct */ @@ -1249,7 +1265,7 @@ gc_mark_loop_first_time: } /* mark vtable */ ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]); - goto gc_mark_loop; + goto_gc_mark_loop; } } break; @@ -1257,11 +1273,11 @@ gc_mark_loop_first_time: if (SCM_IMP (SCM_ENV (ptr))) { ptr = SCM_CLOSCAR (ptr); - goto gc_mark_nimp; + goto_gc_mark_nimp; } RECURSE (SCM_CLOSCAR (ptr)); ptr = SCM_ENV (ptr); - goto gc_mark_nimp; + goto_gc_mark_nimp; case scm_tc7_vector: i = SCM_VECTOR_LENGTH (ptr); if (i == 0) @@ -1270,7 +1286,7 @@ gc_mark_loop_first_time: if (SCM_NIMP (SCM_VELTS (ptr)[i])) RECURSE (SCM_VELTS (ptr)[i]); ptr = SCM_VELTS (ptr)[0]; - goto gc_mark_loop; + goto_gc_mark_loop; #ifdef CCLO case scm_tc7_cclo: { @@ -1283,7 +1299,7 @@ gc_mark_loop_first_time: RECURSE (obj); } ptr = SCM_CCLO_REF (ptr, 0); - goto gc_mark_loop; + goto_gc_mark_loop; } #endif #ifdef HAVE_ARRAYS @@ -1304,7 +1320,7 @@ gc_mark_loop_first_time: case scm_tc7_substring: ptr = SCM_CDR (ptr); - goto gc_mark_loop; + goto_gc_mark_loop; case scm_tc7_wvect: SCM_WVECT_GC_CHAIN (ptr) = scm_weak_vectors; @@ -1367,7 +1383,7 @@ gc_mark_loop_first_time: case scm_tc7_symbol: ptr = SCM_PROP_SLOTS (ptr); - goto gc_mark_loop; + goto_gc_mark_loop; case scm_tcs_subrs: break; case scm_tc7_port: @@ -1381,7 +1397,7 @@ gc_mark_loop_first_time: if (scm_ptobs[i].mark) { ptr = (scm_ptobs[i].mark) (ptr); - goto gc_mark_loop; + goto_gc_mark_loop; } else return; @@ -1404,7 +1420,7 @@ gc_mark_loop_first_time: if (scm_smobs[i].mark) { ptr = (scm_smobs[i].mark) (ptr); - goto gc_mark_loop; + goto_gc_mark_loop; } else return; @@ -2307,50 +2323,6 @@ alloc_some_heap (scm_freelist_t *freelist, policy_on_error error_policy) } #undef FUNC_NAME - -SCM_DEFINE (scm_unhash_name, "unhash-name", 1, 0, 0, - (SCM name), - "Flushes the glocs for @var{name}, or all glocs if @var{name}\n" - "is @code{#t}.") -#define FUNC_NAME s_scm_unhash_name -{ - int x; - int bound; - SCM_VALIDATE_SYMBOL (1,name); - SCM_DEFER_INTS; - bound = scm_n_heap_segs; - for (x = 0; x < bound; ++x) - { - SCM_CELLPTR p; - SCM_CELLPTR pbound; - p = scm_heap_table[x].bounds[0]; - pbound = scm_heap_table[x].bounds[1]; - while (p < pbound) - { - SCM cell = PTR2SCM (p); - if (SCM_TYP3 (cell) == scm_tc3_cons_gloc) - { - /* Dirk:FIXME:: Again, super ugly code: cell may be a gloc or a - * struct cell. See the corresponding comment in scm_gc_mark. - */ - scm_bits_t word0 = SCM_CELL_WORD_0 (cell) - scm_tc3_cons_gloc; - SCM gloc_car = SCM_PACK (word0); /* access as gloc */ - SCM vcell = SCM_CELL_OBJECT_1 (gloc_car); - if ((SCM_EQ_P (name, SCM_BOOL_T) || SCM_EQ_P (SCM_CAR (gloc_car), name)) - && (SCM_UNPACK (vcell) != 0) && (SCM_UNPACK (vcell) != 1)) - { - SCM_SET_CELL_OBJECT_0 (cell, name); - } - } - ++p; - } - } - SCM_ALLOW_INTS; - return name; -} -#undef FUNC_NAME - - /* {GC Protection Helper Functions} */ @@ -2653,10 +2625,6 @@ scm_init_storage () #endif #endif -#define DEFAULT_SYMHASH_SIZE 277 - scm_symhash = scm_c_make_hash_table (DEFAULT_SYMHASH_SIZE); - scm_symhash_vars = scm_c_make_hash_table (DEFAULT_SYMHASH_SIZE); - scm_stand_in_procs = SCM_EOL; scm_permobjs = SCM_EOL; scm_protects = scm_c_make_hash_table (31); diff --git a/libguile/gdbint.c b/libguile/gdbint.c index 8511365d3..3a28549da 100644 --- a/libguile/gdbint.c +++ b/libguile/gdbint.c @@ -300,10 +300,8 @@ gdb_binding (SCM name, SCM value) } SCM_BEGIN_FOREIGN_BLOCK; { - SCM vcell = scm_sym2vcell (name, - SCM_TOP_LEVEL_LOOKUP_CLOSURE, - SCM_BOOL_T); - SCM_SETCDR (vcell, value); + SCM var = scm_sym2var (name, SCM_TOP_LEVEL_LOOKUP_CLOSURE, SCM_BOOL_T); + SCM_VARIABLE_SET (var, value); } SCM_END_FOREIGN_BLOCK; return 0; diff --git a/libguile/gh_data.c b/libguile/gh_data.c index 0ee8896a9..368b223f5 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -708,14 +708,14 @@ SCM gh_module_lookup (SCM module, const char *sname) #define FUNC_NAME "gh_module_lookup" { - SCM sym, cell; + SCM sym, var; SCM_VALIDATE_MODULE (SCM_ARG1, module); sym = gh_symbol2scm (sname); - cell = scm_sym2vcell (sym, scm_module_lookup_closure (module), SCM_BOOL_F); - if (cell != SCM_BOOL_F) - return SCM_CDR (cell); + var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F); + if (var != SCM_BOOL_F) + return SCM_VARIABLE_REF (var); else return SCM_UNDEFINED; } diff --git a/libguile/gh_funcs.c b/libguile/gh_funcs.c index 6f43cf734..cdb07a4cc 100644 --- a/libguile/gh_funcs.c +++ b/libguile/gh_funcs.c @@ -130,7 +130,8 @@ gh_new_procedure5_0 (const char *proc_name, SCM (*fn) ()) SCM gh_define (const char *name, SCM val) { - return scm_sysintern (name, val); + scm_c_define (name, val); + return SCM_UNSPECIFIED; } diff --git a/libguile/goops.c b/libguile/goops.c index a32cba7d9..f108d1407 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -79,7 +79,7 @@ scm_module_goops); } /* Temporary hack until we get the new module system */ /*fixme* Should optimize by keeping track of the variable object itself */ -#define GETVAR(v) (SCM_CDDR (scm_apply (scm_goops_lookup_closure, \ +#define GETVAR(v) (SCM_VARIABLE_REF (scm_apply (scm_goops_lookup_closure, \ SCM_LIST2 ((v), SCM_BOOL_F), \ SCM_EOL))) @@ -1861,7 +1861,8 @@ scm_sys_compute_applicable_methods (SCM gf, SCM args) } #undef FUNC_NAME -SCM_VCELL_INIT (var_compute_applicable_methods, "compute-applicable-methods", scm_make_gsubr (s_sys_compute_applicable_methods, 2, 0, 0, scm_sys_compute_applicable_methods)); +SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods"); +SCM_VARIABLE_INIT (var_compute_applicable_methods, "compute-applicable-methods", scm_make_gsubr (s_sys_compute_applicable_methods, 2, 0, 0, scm_sys_compute_applicable_methods)); SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_makmmacro, scm_m_atslot_ref); @@ -2635,11 +2636,9 @@ SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0, #define FUNC_NAME s_scm_sys_goops_loaded { goops_loaded_p = 1; - var_compute_applicable_methods - = SCM_CDR (scm_apply (scm_goops_lookup_closure, - SCM_LIST2 (SCM_CAR (var_compute_applicable_methods), - SCM_BOOL_F), - SCM_EOL)); + var_compute_applicable_methods = + scm_sym2var (sym_compute_applicable_methods, scm_goops_lookup_closure, + SCM_BOOL_F); return SCM_UNSPECIFIED; } #undef FUNC_NAME diff --git a/libguile/gsubr.c b/libguile/gsubr.c index 83c268479..3b7c08d55 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -77,7 +77,9 @@ scm_make_gsubr(const char *name,int req,int opt,int rst,SCM (*fcn)()) case SCM_GSUBR_MAKTYPE(2, 0, 1): return scm_make_subr(name, scm_tc7_lsubr_2, fcn); default: { - SCM symcell = scm_sysintern (name, SCM_UNDEFINED); + SCM sym = scm_str2symbol (name); + SCM var = scm_sym2var (sym, scm_current_module_lookup_closure (), + SCM_BOOL_T); SCM cclo = scm_makcclo (scm_f_gsubr_apply, 3L); if (SCM_GSUBR_MAX < req + opt + rst) { fputs("ERROR in scm_make_gsubr: too many args\n", stderr); @@ -85,10 +87,10 @@ scm_make_gsubr(const char *name,int req,int opt,int rst,SCM (*fcn)()) } SCM_SET_GSUBR_PROC (cclo, scm_make_subr_opt (name, scm_tc7_subr_0, fcn, 0)); SCM_SET_GSUBR_TYPE (cclo, SCM_MAKINUM (SCM_GSUBR_MAKTYPE (req, opt, rst))); - SCM_SETCDR (symcell, cclo); + SCM_VARIABLE_SET (var, cclo); #ifdef DEBUG_EXTENSIONS if (SCM_REC_PROCNAMES_P) - scm_set_procedure_property_x (cclo, scm_sym_name, SCM_CAR (symcell)); + scm_set_procedure_property_x (cclo, scm_sym_name, sym); #endif return cclo; } diff --git a/libguile/hooks.c b/libguile/hooks.c index 96a9657b3..9834474aa 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -198,7 +198,7 @@ SCM scm_create_hook (const char* name, int n_args) { SCM hook = make_hook (SCM_MAKINUM (n_args), "scm_create_hook"); - scm_sysintern (name, hook); + scm_c_define (name, hook); scm_protect_object (hook); return hook; } diff --git a/libguile/init.c b/libguile/init.c index dacd1ee92..45ecb5f7a 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -366,8 +366,6 @@ scm_load_startup_files () /* Load the init.scm file. */ if (SCM_NFALSEP (init_path)) scm_primitive_load (init_path); - - scm_post_boot_init_modules (); } } @@ -477,6 +475,8 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_weaks_prehistory (); /* requires storage */ scm_init_subr_table (); scm_environments_prehistory (); /* requires storage */ + scm_modules_prehistory (); /* requires storage */ + scm_init_variable (); /* all bindings need variables */ scm_init_continuations (); scm_init_root (); /* requires continuations */ #ifdef USE_THREADS @@ -555,7 +555,6 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_init_strorder (); scm_init_strop (); scm_init_throw (); - scm_init_variable (); scm_init_vectors (); scm_init_version (); scm_init_weaks (); diff --git a/libguile/keywords.c b/libguile/keywords.c index ff86b582f..f17eedacc 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -71,24 +71,21 @@ SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", "Make a keyword object from a @var{symbol} that starts with a dash.") #define FUNC_NAME s_scm_make_keyword_from_dash_symbol { - SCM vcell; + SCM keyword; SCM_ASSERT (SCM_SYMBOLP (symbol) && ('-' == SCM_SYMBOL_CHARS(symbol)[0]), symbol, SCM_ARG1, FUNC_NAME); SCM_DEFER_INTS; - vcell = scm_sym2ovcell_soft (symbol, scm_keyword_obarray); - if (SCM_FALSEP (vcell)) + keyword = scm_hashq_ref (scm_keyword_obarray, symbol, SCM_BOOL_F); + if (SCM_FALSEP (keyword)) { - SCM keyword; SCM_NEWSMOB (keyword, scm_tc16_keyword, SCM_UNPACK (symbol)); - scm_intern_symbol (scm_keyword_obarray, symbol); - vcell = scm_sym2ovcell_soft (symbol, scm_keyword_obarray); - SCM_SETCDR (vcell, keyword); + scm_hashq_set_x (scm_keyword_obarray, symbol, keyword); } SCM_ALLOW_INTS; - return SCM_CDR (vcell); + return keyword; } #undef FUNC_NAME diff --git a/libguile/load.c b/libguile/load.c index 98158e6da..acc75e46f 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -494,7 +494,7 @@ static void init_build_info () { static struct { char *name; char *value; } info[] = SCM_BUILD_INFO; - SCM *loc = SCM_CDRLOC (scm_sysintern ("%guile-build-info", SCM_EOL)); + SCM *loc = SCM_VARIABLE_LOC (scm_c_define ("%guile-build-info", SCM_EOL)); unsigned int i; for (i = 0; i < (sizeof (info) / sizeof (info[0])); i++) @@ -509,12 +509,12 @@ void scm_init_load () { scm_listofnullstr = scm_permanent_object (SCM_LIST1 (scm_nullstr)); - scm_loc_load_path = SCM_CDRLOC (scm_sysintern ("%load-path", SCM_EOL)); + scm_loc_load_path = SCM_VARIABLE_LOC (scm_c_define ("%load-path", SCM_EOL)); scm_loc_load_extensions - = SCM_CDRLOC (scm_sysintern ("%load-extensions", - SCM_LIST2 (scm_makfrom0str (".scm"), - scm_nullstr))); - scm_loc_load_hook = SCM_CDRLOC (scm_sysintern ("%load-hook", SCM_BOOL_F)); + = SCM_VARIABLE_LOC (scm_c_define ("%load-extensions", + SCM_LIST2 (scm_makfrom0str (".scm"), + scm_nullstr))); + scm_loc_load_hook = SCM_VARIABLE_LOC (scm_c_define ("%load-hook", SCM_BOOL_F)); init_build_info (); diff --git a/libguile/macros.c b/libguile/macros.c index 734cd6d5d..79618bd12 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -220,10 +220,10 @@ SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0, SCM scm_make_synt (const char *name, SCM (*macroizer) (), SCM (*fcn)() ) { - SCM symcell = scm_sysintern (name, SCM_UNDEFINED); + SCM var = scm_c_define (name, SCM_UNDEFINED); SCM transformer = scm_make_subr_opt (name, scm_tc7_subr_2, fcn, 0); - SCM_SETCDR (symcell, macroizer (transformer)); - return SCM_CAR (symcell); + SCM_VARIABLE_SET (var, macroizer (transformer)); + return SCM_UNSPECIFIED; } void diff --git a/libguile/modules.c b/libguile/modules.c index 710adddc9..f889fe9aa 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -57,18 +57,20 @@ #include "libguile/modules.h" -SCM scm_module_system_booted_p = 0; +int scm_module_system_booted_p = 0; SCM scm_module_tag; -SCM scm_module_type; -static SCM the_root_module; +static SCM the_root_module_var; static SCM root_module_lookup_closure; SCM scm_the_root_module () { - return SCM_CDR (the_root_module); + if (scm_module_system_booted_p) + return SCM_VARIABLE_REF (the_root_module_var); + else + return SCM_BOOL_F; } static SCM the_module; @@ -82,12 +84,7 @@ SCM_DEFINE (scm_current_module, "current-module", 0, 0, 0, } #undef FUNC_NAME -#define SCM_VALIDATE_STRUCT_TYPE(pos, v, type) \ - do { \ - SCM_ASSERT (SCM_NIMP (v) && SCM_NFALSEP (SCM_STRUCTP (v)) \ - && SCM_STRUCT_VTABLE (v) == (type), \ - v, pos, FUNC_NAME); \ - } while (0) +static void scm_post_boot_init_modules (void); SCM_DEFINE (scm_set_current_module, "set-current-module", 1, 0, 0, (SCM module), @@ -97,21 +94,18 @@ SCM_DEFINE (scm_set_current_module, "set-current-module", 1, 0, 0, { SCM old; - /* XXX - we can not validate our argument when the module system - hasn't been booted yet since we don't know the type. This - should be fixed when we have a cleaner way of booting - Guile. - */ - if (scm_module_system_booted_p) - SCM_VALIDATE_STRUCT_TYPE (SCM_ARG1, module, scm_module_type); + if (!scm_module_system_booted_p) + scm_post_boot_init_modules (); + + SCM_VALIDATE_MODULE (SCM_ARG1, module); old = scm_current_module (); scm_fluid_set_x (the_module, module); #if SCM_DEBUG_DEPRECATED == 0 - scm_fluid_set_x (SCM_CDR (scm_top_level_lookup_closure_var), + scm_fluid_set_x (SCM_VARIABLE_REF (scm_top_level_lookup_closure_var), scm_current_module_lookup_closure ()); - scm_fluid_set_x (SCM_CDR (scm_system_transformer), + scm_fluid_set_x (SCM_VARIABLE_REF (scm_system_transformer), scm_current_module_transformer ()); #endif @@ -145,13 +139,13 @@ scm_module_full_name (SCM name) return scm_append (SCM_LIST2 (module_prefix, name)); } -static SCM make_modules_in; -static SCM beautify_user_module_x; +static SCM make_modules_in_var; +static SCM beautify_user_module_x_var; SCM scm_make_module (SCM name) { - return scm_apply (SCM_CDR (make_modules_in), + return scm_apply (SCM_VARIABLE_REF (make_modules_in_var), SCM_LIST2 (scm_the_root_module (), scm_module_full_name (name)), SCM_EOL); @@ -160,14 +154,18 @@ scm_make_module (SCM name) SCM scm_ensure_user_module (SCM module) { - scm_apply (SCM_CDR (beautify_user_module_x), SCM_LIST1 (module), SCM_EOL); + scm_apply (SCM_VARIABLE_REF (beautify_user_module_x_var), + SCM_LIST1 (module), SCM_EOL); return SCM_UNSPECIFIED; } SCM scm_module_lookup_closure (SCM module) { - return SCM_MODULE_EVAL_CLOSURE (module); + if (module == SCM_BOOL_F) + return SCM_BOOL_F; + else + return SCM_MODULE_EVAL_CLOSURE (module); } SCM @@ -182,7 +180,10 @@ scm_current_module_lookup_closure () SCM scm_module_transformer (SCM module) { - return SCM_MODULE_TRANSFORMER (module); + if (module == SCM_BOOL_F) + return SCM_BOOL_F; + else + return SCM_MODULE_TRANSFORMER (module); } SCM @@ -194,20 +195,22 @@ scm_current_module_transformer () return SCM_BOOL_F; } -static SCM resolve_module; +static SCM resolve_module_var; SCM scm_resolve_module (SCM name) { - return scm_apply (SCM_CDR (resolve_module), SCM_LIST1 (name), SCM_EOL); + return scm_apply (SCM_VARIABLE_REF (resolve_module_var), + SCM_LIST1 (name), SCM_EOL); } -static SCM try_module_autoload; +static SCM try_module_autoload_var; SCM scm_load_scheme_module (SCM name) { - return scm_apply (SCM_CDR (try_module_autoload), SCM_LIST1 (name), SCM_EOL); + return scm_apply (SCM_VARIABLE_REF (try_module_autoload_var), + SCM_LIST1 (name), SCM_EOL); } /* Environments */ @@ -234,6 +237,30 @@ scm_env_top_level (SCM env) return SCM_BOOL_F; } +SCM_SYMBOL (sym_module, "module"); + +SCM +scm_lookup_closure_module (SCM proc) +{ + if (SCM_FALSEP (proc)) + return scm_the_root_module (); + else if (SCM_EVAL_CLOSURE_P (proc)) + return SCM_PACK (SCM_SMOB_DATA (proc)); + else + { + SCM mod = scm_procedure_property (proc, sym_module); + if (mod == SCM_BOOL_F) + mod = scm_the_root_module (); + return mod; + } +} + +SCM +scm_env_module (SCM env) +{ + return scm_lookup_closure_module (scm_env_top_level (env)); +} + SCM_SYMBOL (scm_sym_system_module, "system-module"); @@ -256,7 +283,7 @@ scm_system_module_env_p (SCM env) * The code will be replaced by the low-level environments in next release. */ -static SCM module_make_local_var_x; +static SCM module_make_local_var_x_var; static SCM module_variable (SCM module, SCM sym) @@ -293,6 +320,10 @@ module_variable (SCM module, SCM sym) scm_bits_t scm_tc16_eval_closure; +#define SCM_F_EVAL_CLOSURE_INTERFACE (1<<16) +#define SCM_EVAL_CLOSURE_INTERFACE_P(e) \ + (SCM_CELL_WORD_0 (e) & SCM_F_EVAL_CLOSURE_INTERFACE) + /* NOTE: This function may be called by a smob application or from another C function directly. */ SCM @@ -300,9 +331,13 @@ scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep) { SCM module = SCM_PACK (SCM_SMOB_DATA (eclo)); if (SCM_NFALSEP (definep)) - return scm_apply (SCM_CDR (module_make_local_var_x), - SCM_LIST2 (module, sym), - SCM_EOL); + { + if (SCM_EVAL_CLOSURE_INTERFACE_P (eclo)) + return SCM_BOOL_F; + return scm_apply (SCM_VARIABLE_REF (module_make_local_var_x_var), + SCM_LIST2 (module, sym), + SCM_EOL); + } else return module_variable (module, sym); } @@ -316,14 +351,222 @@ SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_standard_interface_eval_closure, + "standard-interface-eval-closure", 1, 0, 0, + (SCM module), + "Return a interface eval closure for the module @var{module}. " + "Such a closure does not allow new bindings to be added.") +#define FUNC_NAME s_scm_standard_interface_eval_closure +{ + SCM_RETURN_NEWSMOB (scm_tc16_eval_closure | SCM_F_EVAL_CLOSURE_INTERFACE, + SCM_UNPACK (module)); +} +#undef FUNC_NAME + +/* scm_sym2var + * + * looks up the variable bound to SYM according to PROC. PROC should be + * a `eval closure' of some module. + * + * When no binding exists, and DEFINEP is true, create a new binding + * with a initial value of SCM_UNDEFINED. Return `#f' when DEFINEP as + * false and no binding exists. + * + * When PROC is `#f', it is ignored and the binding is searched for in + * the scm_pre_modules_obarray (a `eq' hash table). + */ + +SCM scm_pre_modules_obarray; + +SCM +scm_sym2var (SCM sym, SCM proc, SCM definep) +#define FUNC_NAME "scm_sym2var" +{ + SCM var; + + if (SCM_NIMP (proc)) + { + if (SCM_EVAL_CLOSURE_P (proc)) + { + /* Bypass evaluator in the standard case. */ + var = scm_eval_closure_lookup (proc, sym, definep); + } + else + var = scm_apply (proc, sym, scm_cons (definep, scm_listofnull)); + } + else + { + SCM handle; + + if (definep == SCM_BOOL_F) + var = scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_BOOL_F); + else + { + handle = scm_hashq_create_handle_x (scm_pre_modules_obarray, + sym, SCM_BOOL_F); + var = SCM_CDR (handle); + if (var == SCM_BOOL_F) + { + var = scm_make_variable (SCM_UNDEFINED); +#if SCM_ENABLE_VCELLS + scm_variable_set_name_hint (var, sym); +#endif + SCM_SETCDR (handle, var); + } + } + } + + if (var != SCM_BOOL_F && !SCM_VARIABLEP (var)) + SCM_MISC_ERROR ("~S is not bound to a variable", SCM_LIST1 (sym)); + + return var; +} +#undef FUNC_NAME + +SCM +scm_c_module_lookup (SCM module, const char *name) +{ + return scm_module_lookup (module, scm_str2symbol (name)); +} + +SCM +scm_module_lookup (SCM module, SCM sym) +#define FUNC_NAME "module-lookup" +{ + SCM var; + SCM_VALIDATE_MODULE (1, module); + + var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F); + if (SCM_FALSEP (var)) + SCM_MISC_ERROR ("unbound variable: ~S", SCM_LIST1 (sym)); + return var; +} +#undef FUNC_NAME + +SCM +scm_c_lookup (const char *name) +{ + return scm_lookup (scm_str2symbol (name)); +} + +SCM +scm_lookup (SCM sym) +{ + SCM var = + scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F); + if (SCM_FALSEP (var)) + scm_misc_error ("scm_lookup", "unbound variable: ~S", SCM_LIST1 (sym)); + return var; +} + +SCM +scm_c_module_define (SCM module, const char *name, SCM value) +{ + return scm_module_define (module, scm_str2symbol (name), value); +} + +SCM +scm_module_define (SCM module, SCM sym, SCM value) +#define FUNC_NAME "module-define" +{ + SCM var; + SCM_VALIDATE_MODULE (1, module); + + var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_T); + SCM_VARIABLE_SET (var, value); + return var; +} +#undef FUNC_NAME + +SCM +scm_c_define (const char *name, SCM value) +{ + return scm_define (scm_str2symbol (name), value); +} + +SCM +scm_define (SCM sym, SCM value) +{ + SCM var = + scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T); + SCM_VARIABLE_SET (var, value); + return var; +} + +SCM +scm_module_reverse_lookup (SCM module, SCM variable) +#define FUNC_NAME "module-reverse-lookup" +{ + SCM obarray; + int i, n; + + if (module == SCM_BOOL_F) + obarray = scm_pre_modules_obarray; + else + { + SCM_VALIDATE_MODULE (1, module); + obarray = SCM_MODULE_OBARRAY (module); + } + + /* XXX - We do not use scm_hash_fold here to avoid searching the + whole obarray. We should have a scm_hash_find procedure. */ + + n = SCM_VECTOR_LENGTH (obarray); + for (i = 0; i < n; ++i) + { + SCM ls = SCM_VELTS (obarray)[i], handle; + while (!SCM_NULLP (ls)) + { + handle = SCM_CAR (ls); + if (SCM_CDR (handle) == variable) + return SCM_CAR (handle); + ls = SCM_CDR (ls); + } + } + + /* Try the `uses' list. + */ + { + SCM uses = SCM_MODULE_USES (module); + while (SCM_CONSP (uses)) + { + SCM sym = scm_module_reverse_lookup (SCM_CAR (uses), variable); + if (sym != SCM_BOOL_F) + return sym; + uses = SCM_CDR (uses); + } + } + + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_get_pre_modules_obarray, "%get-pre-modules-obarray", 0, 0, 0, + (), + "Return the obarray that is used for all new bindings before " + "the module system is booted. The first call to " + "@code{set-current-module} will boot the module system.") +#define FUNC_NAME s_scm_get_pre_modules_obarray +{ + return scm_pre_modules_obarray; +} +#undef FUNC_NAME + +void +scm_modules_prehistory () +{ + scm_pre_modules_obarray + = scm_permanent_object (scm_c_make_hash_table (2001)); +} + void scm_init_modules () { #ifndef SCM_MAGIC_SNARFER #include "libguile/modules.x" #endif - module_make_local_var_x = scm_sysintern ("module-make-local-var!", - SCM_UNDEFINED); + module_make_local_var_x_var = scm_c_define ("module-make-local-var!", + SCM_UNDEFINED); scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0); scm_set_smob_mark (scm_tc16_eval_closure, scm_markcdr); scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0); @@ -331,21 +574,21 @@ scm_init_modules () the_module = scm_permanent_object (scm_make_fluid ()); } -void +static void scm_post_boot_init_modules () { - scm_module_type = - scm_permanent_object (SCM_CDR (scm_intern0 ("module-type"))); - scm_module_tag = (SCM_CELL_WORD_1 (scm_module_type) + scm_tc3_cons_gloc); - module_prefix = scm_permanent_object (SCM_LIST2 (scm_sym_app, - scm_sym_modules)); - make_modules_in = scm_intern0 ("make-modules-in"); - beautify_user_module_x = scm_intern0 ("beautify-user-module!"); - the_root_module = scm_intern0 ("the-root-module"); - root_module_lookup_closure = scm_permanent_object - (scm_module_lookup_closure (SCM_CDR (the_root_module))); - resolve_module = scm_intern0 ("resolve-module"); - try_module_autoload = scm_intern0 ("try-module-autoload"); +#define PERM(x) scm_permanent_object(x) + + SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type")); + scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_cons_gloc); + module_prefix = PERM (SCM_LIST2 (scm_sym_app, scm_sym_modules)); + make_modules_in_var = PERM (scm_c_lookup ("make-modules-in")); + beautify_user_module_x_var = PERM (scm_c_lookup ("beautify-user-module!")); + the_root_module_var = PERM (scm_c_lookup ("the-root-module")); + root_module_lookup_closure = + PERM (scm_module_lookup_closure (SCM_VARIABLE_REF (the_root_module_var))); + resolve_module_var = PERM (scm_c_lookup ("resolve-module")); + try_module_autoload_var = PERM (scm_c_lookup ("try-module-autoload")); scm_module_system_booted_p = 1; } diff --git a/libguile/modules.h b/libguile/modules.h index da9913e04..9869e42a0 100644 --- a/libguile/modules.h +++ b/libguile/modules.h @@ -82,7 +82,7 @@ extern scm_bits_t scm_tc16_eval_closure; -extern SCM scm_module_system_booted_p; +extern int scm_module_system_booted_p; extern SCM scm_module_tag; extern SCM scm_the_root_module (void); @@ -102,8 +102,27 @@ extern SCM scm_top_level_env (SCM thunk); extern SCM scm_system_module_env_p (SCM env); extern SCM scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep); extern SCM scm_standard_eval_closure (SCM module); +extern SCM scm_standard_interface_eval_closure (SCM module); +extern SCM scm_get_pre_modules_obarray (void); + +extern SCM scm_lookup_closure_module (SCM proc); +extern SCM scm_env_module (SCM env); + +extern SCM scm_c_lookup (const char *name); +extern SCM scm_c_define (const char *name, SCM val); +extern SCM scm_lookup (SCM symbol); +extern SCM scm_define (SCM symbol, SCM val); + +extern SCM scm_c_module_lookup (SCM module, const char *name); +extern SCM scm_c_module_define (SCM module, const char *name, SCM val); +extern SCM scm_module_lookup (SCM module, SCM symbol); +extern SCM scm_module_define (SCM module, SCM symbol, SCM val); +extern SCM scm_module_reverse_lookup (SCM module, SCM variable); + +extern SCM scm_sym2var (SCM sym, SCM thunk, SCM definep); + +extern void scm_modules_prehistory (void); extern void scm_init_modules (void); -extern void scm_post_boot_init_modules (void); #endif /* MODULESH */ diff --git a/libguile/numbers.c b/libguile/numbers.c index a0405d5ff..26da3e4ad 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -4546,8 +4546,10 @@ scm_init_numbers () * the following constants to avoid the creation of bignums. Please, before * using these values, remember the two rules of program optimization: * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */ - scm_sysintern ("most-positive-fixnum", SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)); - scm_sysintern ("most-negative-fixnum", SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)); + scm_c_define ("most-positive-fixnum", + SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)); + scm_c_define ("most-negative-fixnum", + SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)); scm_add_feature ("complex"); scm_add_feature ("inexact"); diff --git a/libguile/objects.c b/libguile/objects.c index 82033b378..ac32e89ec 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -509,13 +509,13 @@ scm_init_objects () SCM et = scm_make_struct (mt, SCM_INUM0, SCM_LIST4 (el, SCM_BOOL_F, SCM_EOL, SCM_EOL)); - scm_sysintern ("", mt); + scm_c_define ("", mt); scm_metaclass_standard = mt; - scm_sysintern ("", ot); + scm_c_define ("", ot); scm_metaclass_operator = ot; SCM_SET_CLASS_FLAGS (et, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY); SCM_SET_CLASS_DESTRUCTOR (et, scm_struct_free_entity); - scm_sysintern ("", et); + scm_c_define ("", et); #ifndef SCM_MAGIC_SNARFER #include "libguile/objects.x" diff --git a/libguile/ports.c b/libguile/ports.c index 91e2a79b5..6a15c2c0b 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1564,9 +1564,9 @@ void scm_init_ports () { /* lseek() symbols. */ - scm_sysintern ("SEEK_SET", SCM_MAKINUM (SEEK_SET)); - scm_sysintern ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR)); - scm_sysintern ("SEEK_END", SCM_MAKINUM (SEEK_END)); + scm_c_define ("SEEK_SET", SCM_MAKINUM (SEEK_SET)); + scm_c_define ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR)); + scm_c_define ("SEEK_END", SCM_MAKINUM (SEEK_END)); scm_tc16_void_port = scm_make_port_type ("void", fill_input_void_port, write_void_port); diff --git a/libguile/posix.c b/libguile/posix.c index 4c4ee235d..6f8c11e0a 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1572,70 +1572,70 @@ scm_init_posix () scm_add_feature ("EIDs"); #endif #ifdef WAIT_ANY - scm_sysintern ("WAIT_ANY", SCM_MAKINUM (WAIT_ANY)); + scm_c_define ("WAIT_ANY", SCM_MAKINUM (WAIT_ANY)); #endif #ifdef WAIT_MYPGRP - scm_sysintern ("WAIT_MYPGRP", SCM_MAKINUM (WAIT_MYPGRP)); + scm_c_define ("WAIT_MYPGRP", SCM_MAKINUM (WAIT_MYPGRP)); #endif #ifdef WNOHANG - scm_sysintern ("WNOHANG", SCM_MAKINUM (WNOHANG)); + scm_c_define ("WNOHANG", SCM_MAKINUM (WNOHANG)); #endif #ifdef WUNTRACED - scm_sysintern ("WUNTRACED", SCM_MAKINUM (WUNTRACED)); + scm_c_define ("WUNTRACED", SCM_MAKINUM (WUNTRACED)); #endif /* access() symbols. */ - scm_sysintern ("R_OK", SCM_MAKINUM (R_OK)); - scm_sysintern ("W_OK", SCM_MAKINUM (W_OK)); - scm_sysintern ("X_OK", SCM_MAKINUM (X_OK)); - scm_sysintern ("F_OK", SCM_MAKINUM (F_OK)); + scm_c_define ("R_OK", SCM_MAKINUM (R_OK)); + scm_c_define ("W_OK", SCM_MAKINUM (W_OK)); + scm_c_define ("X_OK", SCM_MAKINUM (X_OK)); + scm_c_define ("F_OK", SCM_MAKINUM (F_OK)); #ifdef LC_COLLATE - scm_sysintern ("LC_COLLATE", SCM_MAKINUM (LC_COLLATE)); + scm_c_define ("LC_COLLATE", SCM_MAKINUM (LC_COLLATE)); #endif #ifdef LC_CTYPE - scm_sysintern ("LC_CTYPE", SCM_MAKINUM (LC_CTYPE)); + scm_c_define ("LC_CTYPE", SCM_MAKINUM (LC_CTYPE)); #endif #ifdef LC_MONETARY - scm_sysintern ("LC_MONETARY", SCM_MAKINUM (LC_MONETARY)); + scm_c_define ("LC_MONETARY", SCM_MAKINUM (LC_MONETARY)); #endif #ifdef LC_NUMERIC - scm_sysintern ("LC_NUMERIC", SCM_MAKINUM (LC_NUMERIC)); + scm_c_define ("LC_NUMERIC", SCM_MAKINUM (LC_NUMERIC)); #endif #ifdef LC_TIME - scm_sysintern ("LC_TIME", SCM_MAKINUM (LC_TIME)); + scm_c_define ("LC_TIME", SCM_MAKINUM (LC_TIME)); #endif #ifdef LC_MESSAGES - scm_sysintern ("LC_MESSAGES", SCM_MAKINUM (LC_MESSAGES)); + scm_c_define ("LC_MESSAGES", SCM_MAKINUM (LC_MESSAGES)); #endif #ifdef LC_ALL - scm_sysintern ("LC_ALL", SCM_MAKINUM (LC_ALL)); + scm_c_define ("LC_ALL", SCM_MAKINUM (LC_ALL)); #endif #ifdef PIPE_BUF -scm_sysintern ("PIPE_BUF", scm_long2num (PIPE_BUF)); + scm_c_define ("PIPE_BUF", scm_long2num (PIPE_BUF)); #endif #ifdef PRIO_PROCESS - scm_sysintern ("PRIO_PROCESS", SCM_MAKINUM (PRIO_PROCESS)); + scm_c_define ("PRIO_PROCESS", SCM_MAKINUM (PRIO_PROCESS)); #endif #ifdef PRIO_PGRP - scm_sysintern ("PRIO_PGRP", SCM_MAKINUM (PRIO_PGRP)); + scm_c_define ("PRIO_PGRP", SCM_MAKINUM (PRIO_PGRP)); #endif #ifdef PRIO_USER - scm_sysintern ("PRIO_USER", SCM_MAKINUM (PRIO_USER)); + scm_c_define ("PRIO_USER", SCM_MAKINUM (PRIO_USER)); #endif #ifdef LOCK_SH - scm_sysintern ("LOCK_SH", SCM_MAKINUM (LOCK_SH)); + scm_c_define ("LOCK_SH", SCM_MAKINUM (LOCK_SH)); #endif #ifdef LOCK_EX - scm_sysintern ("LOCK_EX", SCM_MAKINUM (LOCK_EX)); + scm_c_define ("LOCK_EX", SCM_MAKINUM (LOCK_EX)); #endif #ifdef LOCK_UN - scm_sysintern ("LOCK_UN", SCM_MAKINUM (LOCK_UN)); + scm_c_define ("LOCK_UN", SCM_MAKINUM (LOCK_UN)); #endif #ifdef LOCK_NB - scm_sysintern ("LOCK_NB", SCM_MAKINUM (LOCK_NB)); + scm_c_define ("LOCK_NB", SCM_MAKINUM (LOCK_NB)); #endif #include "libguile/cpp_sig_symbols.c" diff --git a/libguile/print.c b/libguile/print.c index 1bd903529..dca8d84df 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -371,7 +371,8 @@ taloop: case scm_tc3_cons_gloc: /* gloc */ scm_puts ("#@", port); - exp = SCM_GLOC_SYM (exp); + exp = scm_module_reverse_lookup (scm_current_module (), + SCM_GLOC_VAR (exp)); goto taloop; case scm_tc3_cons: switch (SCM_TYP7 (exp)) diff --git a/libguile/procs.c b/libguile/procs.c index e9ba44f08..65331edb8 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -73,7 +73,7 @@ SCM scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set) { SCM symbol; - SCM symcell; + SCM var; register SCM z; int entry; @@ -89,17 +89,14 @@ scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set) scm_subr_table_room = new_size; } + symbol = scm_str2symbol (name); + SCM_NEWCELL (z); if (set) - { - symcell = scm_sysintern (name, SCM_UNDEFINED); - symbol = SCM_CAR (symcell); - } + var = scm_sym2var (symbol, scm_current_module_lookup_closure (), + SCM_BOOL_T); else - { - symcell = SCM_BOOL_F; /* to avoid warning */ - symbol = scm_str2symbol (name); - } + var = SCM_BOOL_F; entry = scm_subr_table_size; scm_subr_table[entry].handle = z; @@ -112,7 +109,7 @@ scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set) scm_subr_table_size++; if (set) - SCM_SETCDR (symcell, z); + SCM_VARIABLE_SET (var, z); return z; } diff --git a/libguile/ramap.c b/libguile/ramap.c index c594828ff..5fe765624 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -2043,12 +2043,19 @@ scm_array_equal_p (SCM ra0, SCM ra1) } - static void init_raprocs (ra_iproc *subra) { for (; subra->name; subra++) - subra->sproc = scm_symbol_binding (SCM_BOOL_F, scm_str2symbol (subra->name)); + { + SCM sym = scm_str2symbol (subra->name); + SCM var = + scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F); + if (var != SCM_BOOL_F) + subra->sproc = SCM_VARIABLE_REF (var); + else + subra->sproc = SCM_BOOL_F; + } } diff --git a/libguile/random.c b/libguile/random.c index 384731478..63cfffe33 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -352,7 +352,7 @@ rstate_free (SCM rstate) * Scheme level interface. */ -SCM_GLOBAL_VCELL_INIT (scm_var_random_state, "*random-state*", scm_seed_to_random_state (scm_makfrom0str ("URL:http://stat.fsu.edu/~geo/diehard.html"))); +SCM_GLOBAL_VARIABLE_INIT (scm_var_random_state, "*random-state*", scm_seed_to_random_state (scm_makfrom0str ("URL:http://stat.fsu.edu/~geo/diehard.html"))); SCM_DEFINE (scm_random, "random", 1, 1, 0, (SCM n, SCM state), @@ -371,7 +371,7 @@ SCM_DEFINE (scm_random, "random", 1, 1, 0, #define FUNC_NAME s_scm_random { if (SCM_UNBNDP (state)) - state = SCM_CDR (scm_var_random_state); + state = SCM_VARIABLE_REF (scm_var_random_state); SCM_VALIDATE_RSTATE (2,state); if (SCM_INUMP (n)) { @@ -394,7 +394,7 @@ SCM_DEFINE (scm_copy_random_state, "copy-random-state", 0, 1, 0, #define FUNC_NAME s_scm_copy_random_state { if (SCM_UNBNDP (state)) - state = SCM_CDR (scm_var_random_state); + state = SCM_VARIABLE_REF (scm_var_random_state); SCM_VALIDATE_RSTATE (1,state); return make_rstate (scm_the_rng.copy_rstate (SCM_RSTATE (state))); } @@ -420,7 +420,7 @@ SCM_DEFINE (scm_random_uniform, "random:uniform", 0, 1, 0, #define FUNC_NAME s_scm_random_uniform { if (SCM_UNBNDP (state)) - state = SCM_CDR (scm_var_random_state); + state = SCM_VARIABLE_REF (scm_var_random_state); SCM_VALIDATE_RSTATE (1,state); return scm_make_real (scm_c_uniform01 (SCM_RSTATE (state))); } @@ -435,7 +435,7 @@ SCM_DEFINE (scm_random_normal, "random:normal", 0, 1, 0, #define FUNC_NAME s_scm_random_normal { if (SCM_UNBNDP (state)) - state = SCM_CDR (scm_var_random_state); + state = SCM_VARIABLE_REF (scm_var_random_state); SCM_VALIDATE_RSTATE (1,state); return scm_make_real (scm_c_normal01 (SCM_RSTATE (state))); } @@ -492,7 +492,7 @@ SCM_DEFINE (scm_random_solid_sphere_x, "random:solid-sphere!", 1, 1, 0, { SCM_VALIDATE_VECTOR_OR_DVECTOR (1,v); if (SCM_UNBNDP (state)) - state = SCM_CDR (scm_var_random_state); + state = SCM_VARIABLE_REF (scm_var_random_state); SCM_VALIDATE_RSTATE (2,state); scm_random_normal_vector_x (v, state); vector_scale (v, @@ -515,7 +515,7 @@ SCM_DEFINE (scm_random_hollow_sphere_x, "random:hollow-sphere!", 1, 1, 0, { SCM_VALIDATE_VECTOR_OR_DVECTOR (1,v); if (SCM_UNBNDP (state)) - state = SCM_CDR (scm_var_random_state); + state = SCM_VARIABLE_REF (scm_var_random_state); SCM_VALIDATE_RSTATE (2,state); scm_random_normal_vector_x (v, state); vector_scale (v, 1 / sqrt (vector_sum_squares (v))); @@ -534,7 +534,7 @@ SCM_DEFINE (scm_random_normal_vector_x, "random:normal-vector!", 1, 1, 0, int n; SCM_VALIDATE_VECTOR_OR_DVECTOR (1,v); if (SCM_UNBNDP (state)) - state = SCM_CDR (scm_var_random_state); + state = SCM_VARIABLE_REF (scm_var_random_state); SCM_VALIDATE_RSTATE (2,state); n = SCM_INUM (scm_uniform_vector_length (v)); if (SCM_VECTORP (v)) @@ -557,7 +557,7 @@ SCM_DEFINE (scm_random_exp, "random:exp", 0, 1, 0, #define FUNC_NAME s_scm_random_exp { if (SCM_UNBNDP (state)) - state = SCM_CDR (scm_var_random_state); + state = SCM_VARIABLE_REF (scm_var_random_state); SCM_VALIDATE_RSTATE (1,state); return scm_make_real (scm_c_exp1 (SCM_RSTATE (state))); } diff --git a/libguile/read.c b/libguile/read.c index 221035ff1..635a4ae42 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -819,7 +819,7 @@ void scm_init_read () { scm_read_hash_procedures = - SCM_CDRLOC (scm_sysintern ("read-hash-procedures", SCM_EOL)); + SCM_VARIABLE_LOC (scm_c_define ("read-hash-procedures", SCM_EOL)); scm_init_opts (scm_read_options, scm_read_opts, SCM_N_READ_OPTIONS); #ifndef SCM_MAGIC_SNARFER diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index df7fe06a0..1f02d688b 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -303,14 +303,14 @@ scm_init_regex_posix () scm_set_smob_free (scm_tc16_regex, regex_free); /* Compilation flags. */ - scm_sysintern ("regexp/basic", scm_long2num (REG_BASIC)); - scm_sysintern ("regexp/extended", scm_long2num (REG_EXTENDED)); - scm_sysintern ("regexp/icase", scm_long2num (REG_ICASE)); - scm_sysintern ("regexp/newline", scm_long2num (REG_NEWLINE)); + scm_c_define ("regexp/basic", scm_long2num (REG_BASIC)); + scm_c_define ("regexp/extended", scm_long2num (REG_EXTENDED)); + scm_c_define ("regexp/icase", scm_long2num (REG_ICASE)); + scm_c_define ("regexp/newline", scm_long2num (REG_NEWLINE)); /* Execution flags. */ - scm_sysintern ("regexp/notbol", scm_long2num (REG_NOTBOL)); - scm_sysintern ("regexp/noteol", scm_long2num (REG_NOTEOL)); + scm_c_define ("regexp/notbol", scm_long2num (REG_NOTBOL)); + scm_c_define ("regexp/noteol", scm_long2num (REG_NOTEOL)); #ifndef SCM_MAGIC_SNARFER #include "libguile/regex-posix.x" diff --git a/libguile/root.h b/libguile/root.h index 82e12312c..40671e55e 100644 --- a/libguile/root.h +++ b/libguile/root.h @@ -61,20 +61,18 @@ #define scm_undefineds scm_sys_protects[2] #define scm_nullvect scm_sys_protects[3] #define scm_nullstr scm_sys_protects[4] -#define scm_symhash scm_sys_protects[5] -#define scm_symhash_vars scm_sys_protects[6] -#define scm_keyword_obarray scm_sys_protects[7] -#define scm_stand_in_procs scm_sys_protects[8] -#define scm_object_whash scm_sys_protects[9] -#define scm_permobjs scm_sys_protects[10] -#define scm_asyncs scm_sys_protects[11] -#define scm_protects scm_sys_protects[12] -#define scm_properties_whash scm_sys_protects[13] +#define scm_keyword_obarray scm_sys_protects[5] +#define scm_stand_in_procs scm_sys_protects[6] +#define scm_object_whash scm_sys_protects[7] +#define scm_permobjs scm_sys_protects[8] +#define scm_asyncs scm_sys_protects[9] +#define scm_protects scm_sys_protects[10] +#define scm_properties_whash scm_sys_protects[11] #ifdef DEBUG_EXTENSIONS -#define scm_source_whash scm_sys_protects[14] -#define SCM_NUM_PROTECTS 15 +#define scm_source_whash scm_sys_protects[12] +#define SCM_NUM_PROTECTS 13 #else -#define SCM_NUM_PROTECTS 14 +#define SCM_NUM_PROTECTS 12 #endif extern SCM scm_sys_protects[]; diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index bc57429ae..380dea0c2 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -492,8 +492,8 @@ scm_init_scmsigs () int i; signal_handlers = - SCM_CDRLOC (scm_sysintern ("signal-handlers", - scm_c_make_vector (NSIG, SCM_BOOL_F))); + SCM_VARIABLE_LOC (scm_c_define ("signal-handlers", + scm_c_make_vector (NSIG, SCM_BOOL_F))); thunk = scm_make_gsubr ("%deliver-signals", 0, 0, 0, sys_deliver_signals); signal_async = scm_system_async (thunk); @@ -532,14 +532,14 @@ scm_init_scmsigs () #endif } - scm_sysintern ("NSIG", scm_long2num (NSIG)); - scm_sysintern ("SIG_IGN", scm_long2num ((long) SIG_IGN)); - scm_sysintern ("SIG_DFL", scm_long2num ((long) SIG_DFL)); + scm_c_define ("NSIG", scm_long2num (NSIG)); + scm_c_define ("SIG_IGN", scm_long2num ((long) SIG_IGN)); + scm_c_define ("SIG_DFL", scm_long2num ((long) SIG_DFL)); #ifdef SA_NOCLDSTOP - scm_sysintern ("SA_NOCLDSTOP", scm_long2num (SA_NOCLDSTOP)); + scm_c_define ("SA_NOCLDSTOP", scm_long2num (SA_NOCLDSTOP)); #endif #ifdef SA_RESTART - scm_sysintern ("SA_RESTART", scm_long2num (SA_RESTART)); + scm_c_define ("SA_RESTART", scm_long2num (SA_RESTART)); #endif #ifndef SCM_MAGIC_SNARFER diff --git a/libguile/script.c b/libguile/script.c index ae2a738e0..2bcb184a1 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -571,7 +571,7 @@ scm_compile_shell_switches (int argc, char **argv) scm_set_program_arguments (argc ? argc - i : 0, argv + i, argv0); /* If the --emacs switch was set, now is when we process it. */ - scm_sysintern ("use-emacs-interface", SCM_BOOL (use_emacs_interface)); + scm_c_define ("use-emacs-interface", SCM_BOOL (use_emacs_interface)); /* Handle the `-e' switch, if it was specified. */ if (!SCM_NULLP (entry_point)) diff --git a/libguile/snarf.h b/libguile/snarf.h index 540c95947..9aef75fcc 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -172,6 +172,27 @@ SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_make_keyword (scheme_name))) SCM_SNARF_HERE(SCM c_name) \ SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_make_keyword (scheme_name))) +#define SCM_VARIABLE(c_name, scheme_name) \ +SCM_SNARF_HERE(static SCM c_name) \ +SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, SCM_BOOL_F));) + +#define SCM_GLOBAL_VARIABLE(c_name, scheme_name) \ +SCM_SNARF_HERE(SCM c_name) \ +SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, SCM_BOOL_F));) + +#define SCM_VARIABLE_INIT(c_name, scheme_name, init_val) \ +SCM_SNARF_HERE(static SCM c_name) \ +SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, init_val));) + +#define SCM_GLOBAL_VARIABLE_INIT(c_name, scheme_name, init_val) \ +SCM_SNARF_HERE(SCM c_name) \ +SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, init_val));) + +#if (SCM_DEBUG_DEPRECATED == 0) + +#define SCM_CONST_LONG(c_name, scheme_name,value) \ +SCM_VARIABLE_INIT(c_name, scheme_name, scm_long2num(value)) + #define SCM_VCELL(c_name, scheme_name) \ SCM_SNARF_HERE(static SCM c_name) \ SCM_SNARF_INIT(c_name = scm_permanent_object (scm_sysintern (scheme_name, SCM_BOOL_F));) @@ -188,11 +209,6 @@ SCM_SNARF_INIT(c_name = scm_permanent_object (scm_sysintern (scheme_name, init_v SCM_SNARF_HERE(SCM c_name) \ SCM_SNARF_INIT(c_name = scm_permanent_object (scm_sysintern (scheme_name, init_val));) -#if (SCM_DEBUG_DEPRECATED == 0) - -#define SCM_CONST_LONG(c_name, scheme_name,value) \ -SCM_VCELL_INIT(c_name, scheme_name, scm_long2num(value)) - #endif /* (SCM_DEBUG_DEPRECATED == 0) */ #ifdef SCM_MAGIC_SNARFER diff --git a/libguile/socket.c b/libguile/socket.c index c9cbef07b..5fbba91ca 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -1264,123 +1264,123 @@ scm_init_socket () { /* protocol families. */ #ifdef AF_UNSPEC - scm_sysintern ("AF_UNSPEC", SCM_MAKINUM (AF_UNSPEC)); + scm_c_define ("AF_UNSPEC", SCM_MAKINUM (AF_UNSPEC)); #endif #ifdef AF_UNIX - scm_sysintern ("AF_UNIX", SCM_MAKINUM (AF_UNIX)); + scm_c_define ("AF_UNIX", SCM_MAKINUM (AF_UNIX)); #endif #ifdef AF_INET - scm_sysintern ("AF_INET", SCM_MAKINUM (AF_INET)); + scm_c_define ("AF_INET", SCM_MAKINUM (AF_INET)); #endif #ifdef AF_INET6 - scm_sysintern ("AF_INET6", SCM_MAKINUM (AF_INET6)); + scm_c_define ("AF_INET6", SCM_MAKINUM (AF_INET6)); #endif #ifdef PF_UNSPEC - scm_sysintern ("PF_UNSPEC", SCM_MAKINUM (PF_UNSPEC)); + scm_c_define ("PF_UNSPEC", SCM_MAKINUM (PF_UNSPEC)); #endif #ifdef PF_UNIX - scm_sysintern ("PF_UNIX", SCM_MAKINUM (PF_UNIX)); + scm_c_define ("PF_UNIX", SCM_MAKINUM (PF_UNIX)); #endif #ifdef PF_INET - scm_sysintern ("PF_INET", SCM_MAKINUM (PF_INET)); + scm_c_define ("PF_INET", SCM_MAKINUM (PF_INET)); #endif #ifdef PF_INET6 - scm_sysintern ("PF_INET6", SCM_MAKINUM (PF_INET6)); + scm_c_define ("PF_INET6", SCM_MAKINUM (PF_INET6)); #endif /* standard addresses. */ #ifdef INADDR_ANY - scm_sysintern ("INADDR_ANY", scm_ulong2num (INADDR_ANY)); + scm_c_define ("INADDR_ANY", scm_ulong2num (INADDR_ANY)); #endif #ifdef INADDR_BROADCAST - scm_sysintern ("INADDR_BROADCAST", scm_ulong2num (INADDR_BROADCAST)); + scm_c_define ("INADDR_BROADCAST", scm_ulong2num (INADDR_BROADCAST)); #endif #ifdef INADDR_NONE - scm_sysintern ("INADDR_NONE", scm_ulong2num (INADDR_NONE)); + scm_c_define ("INADDR_NONE", scm_ulong2num (INADDR_NONE)); #endif #ifdef INADDR_LOOPBACK - scm_sysintern ("INADDR_LOOPBACK", scm_ulong2num (INADDR_LOOPBACK)); + scm_c_define ("INADDR_LOOPBACK", scm_ulong2num (INADDR_LOOPBACK)); #endif /* socket types. */ #ifdef SOCK_STREAM - scm_sysintern ("SOCK_STREAM", SCM_MAKINUM (SOCK_STREAM)); + scm_c_define ("SOCK_STREAM", SCM_MAKINUM (SOCK_STREAM)); #endif #ifdef SOCK_DGRAM - scm_sysintern ("SOCK_DGRAM", SCM_MAKINUM (SOCK_DGRAM)); + scm_c_define ("SOCK_DGRAM", SCM_MAKINUM (SOCK_DGRAM)); #endif #ifdef SOCK_RAW - scm_sysintern ("SOCK_RAW", SCM_MAKINUM (SOCK_RAW)); + scm_c_define ("SOCK_RAW", SCM_MAKINUM (SOCK_RAW)); #endif /* setsockopt level. */ #ifdef SOL_SOCKET - scm_sysintern ("SOL_SOCKET", SCM_MAKINUM (SOL_SOCKET)); + scm_c_define ("SOL_SOCKET", SCM_MAKINUM (SOL_SOCKET)); #endif #ifdef SOL_IP - scm_sysintern ("SOL_IP", SCM_MAKINUM (SOL_IP)); + scm_c_define ("SOL_IP", SCM_MAKINUM (SOL_IP)); #endif #ifdef SOL_TCP - scm_sysintern ("SOL_TCP", SCM_MAKINUM (SOL_TCP)); + scm_c_define ("SOL_TCP", SCM_MAKINUM (SOL_TCP)); #endif #ifdef SOL_UDP - scm_sysintern ("SOL_UDP", SCM_MAKINUM (SOL_UDP)); + scm_c_define ("SOL_UDP", SCM_MAKINUM (SOL_UDP)); #endif /* setsockopt names. */ #ifdef SO_DEBUG - scm_sysintern ("SO_DEBUG", SCM_MAKINUM (SO_DEBUG)); + scm_c_define ("SO_DEBUG", SCM_MAKINUM (SO_DEBUG)); #endif #ifdef SO_REUSEADDR - scm_sysintern ("SO_REUSEADDR", SCM_MAKINUM (SO_REUSEADDR)); + scm_c_define ("SO_REUSEADDR", SCM_MAKINUM (SO_REUSEADDR)); #endif #ifdef SO_STYLE - scm_sysintern ("SO_STYLE", SCM_MAKINUM (SO_STYLE)); + scm_c_define ("SO_STYLE", SCM_MAKINUM (SO_STYLE)); #endif #ifdef SO_TYPE - scm_sysintern ("SO_TYPE", SCM_MAKINUM (SO_TYPE)); + scm_c_define ("SO_TYPE", SCM_MAKINUM (SO_TYPE)); #endif #ifdef SO_ERROR - scm_sysintern ("SO_ERROR", SCM_MAKINUM (SO_ERROR)); + scm_c_define ("SO_ERROR", SCM_MAKINUM (SO_ERROR)); #endif #ifdef SO_DONTROUTE - scm_sysintern ("SO_DONTROUTE", SCM_MAKINUM (SO_DONTROUTE)); + scm_c_define ("SO_DONTROUTE", SCM_MAKINUM (SO_DONTROUTE)); #endif #ifdef SO_BROADCAST - scm_sysintern ("SO_BROADCAST", SCM_MAKINUM (SO_BROADCAST)); + scm_c_define ("SO_BROADCAST", SCM_MAKINUM (SO_BROADCAST)); #endif #ifdef SO_SNDBUF - scm_sysintern ("SO_SNDBUF", SCM_MAKINUM (SO_SNDBUF)); + scm_c_define ("SO_SNDBUF", SCM_MAKINUM (SO_SNDBUF)); #endif #ifdef SO_RCVBUF - scm_sysintern ("SO_RCVBUF", SCM_MAKINUM (SO_RCVBUF)); + scm_c_define ("SO_RCVBUF", SCM_MAKINUM (SO_RCVBUF)); #endif #ifdef SO_KEEPALIVE - scm_sysintern ("SO_KEEPALIVE", SCM_MAKINUM (SO_KEEPALIVE)); + scm_c_define ("SO_KEEPALIVE", SCM_MAKINUM (SO_KEEPALIVE)); #endif #ifdef SO_OOBINLINE - scm_sysintern ("SO_OOBINLINE", SCM_MAKINUM (SO_OOBINLINE)); + scm_c_define ("SO_OOBINLINE", SCM_MAKINUM (SO_OOBINLINE)); #endif #ifdef SO_NO_CHECK - scm_sysintern ("SO_NO_CHECK", SCM_MAKINUM (SO_NO_CHECK)); + scm_c_define ("SO_NO_CHECK", SCM_MAKINUM (SO_NO_CHECK)); #endif #ifdef SO_PRIORITY - scm_sysintern ("SO_PRIORITY", SCM_MAKINUM (SO_PRIORITY)); + scm_c_define ("SO_PRIORITY", SCM_MAKINUM (SO_PRIORITY)); #endif #ifdef SO_LINGER - scm_sysintern ("SO_LINGER", SCM_MAKINUM (SO_LINGER)); + scm_c_define ("SO_LINGER", SCM_MAKINUM (SO_LINGER)); #endif /* recv/send options. */ #ifdef MSG_OOB - scm_sysintern ("MSG_OOB", SCM_MAKINUM (MSG_OOB)); + scm_c_define ("MSG_OOB", SCM_MAKINUM (MSG_OOB)); #endif #ifdef MSG_PEEK - scm_sysintern ("MSG_PEEK", SCM_MAKINUM (MSG_PEEK)); + scm_c_define ("MSG_PEEK", SCM_MAKINUM (MSG_PEEK)); #endif #ifdef MSG_DONTROUTE - scm_sysintern ("MSG_DONTROUTE", SCM_MAKINUM (MSG_DONTROUTE)); + scm_c_define ("MSG_DONTROUTE", SCM_MAKINUM (MSG_DONTROUTE)); #endif scm_add_feature ("socket"); diff --git a/libguile/srcprop.c b/libguile/srcprop.c index 606a62392..ef368aa2c 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -334,7 +334,7 @@ scm_init_srcprop () scm_set_smob_print (scm_tc16_srcprops, srcprops_print); scm_source_whash = scm_make_weak_key_hash_table (SCM_MAKINUM (2047)); - scm_sysintern ("source-whash", scm_source_whash); + scm_c_define ("source-whash", scm_source_whash); #ifndef SCM_MAGIC_SNARFER #include "libguile/srcprop.x" diff --git a/libguile/stacks.c b/libguile/stacks.c index c43ba9b2c..63bbda07b 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -221,9 +221,9 @@ read_frame (scm_debug_frame *dframe,long offset,scm_info_frame *iframe) static SCM get_applybody () { - SCM cell = scm_sym2vcell (scm_sym_apply, SCM_BOOL_F, SCM_BOOL_F); - if (SCM_CONSP (cell) && SCM_CLOSUREP (SCM_CDR (cell))) - return SCM_CADR (SCM_CODE (SCM_CDR (cell))); + SCM var = scm_sym2var (scm_sym_apply, SCM_BOOL_F, SCM_BOOL_F); + if (SCM_VARIABLEP (var) && SCM_CLOSUREP (SCM_VARIABLE_REF (var))) + return SCM_CADR (SCM_CODE (SCM_VARIABLE_REF (var))); else return SCM_UNDEFINED; } diff --git a/libguile/stime.c b/libguile/stime.c index d63ad85d3..ac99a1587 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -706,7 +706,7 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, void scm_init_stime() { - scm_sysintern("internal-time-units-per-second", + scm_c_define ("internal-time-units-per-second", scm_long2num((long)CLKTCK)); #ifdef HAVE_FTIME diff --git a/libguile/struct.c b/libguile/struct.c index 3262ef968..4e8db5d17 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -820,10 +820,11 @@ scm_init_struct () = scm_permanent_object (scm_make_weak_key_hash_table (SCM_MAKINUM (31))); required_vtable_fields = scm_makfrom0str ("pruosrpw"); scm_permanent_object (required_vtable_fields); - scm_sysintern ("vtable-index-layout", SCM_MAKINUM (scm_vtable_index_layout)); - scm_sysintern ("vtable-index-vtable", SCM_MAKINUM (scm_vtable_index_vtable)); - scm_sysintern ("vtable-index-printer", SCM_MAKINUM (scm_vtable_index_printer)); - scm_sysintern ("vtable-offset-user", SCM_MAKINUM (scm_vtable_offset_user)); + scm_c_define ("vtable-index-layout", SCM_MAKINUM (scm_vtable_index_layout)); + scm_c_define ("vtable-index-vtable", SCM_MAKINUM (scm_vtable_index_vtable)); + scm_c_define ("vtable-index-printer", + SCM_MAKINUM (scm_vtable_index_printer)); + scm_c_define ("vtable-offset-user", SCM_MAKINUM (scm_vtable_offset_user)); #ifndef SCM_MAGIC_SNARFER #include "libguile/struct.x" #endif diff --git a/libguile/symbols-deprecated.c b/libguile/symbols-deprecated.c new file mode 100644 index 000000000..49ba28799 --- /dev/null +++ b/libguile/symbols-deprecated.c @@ -0,0 +1,637 @@ +/* Copyright (C) 1995,1996,1997,1998, 2000, 2001 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + + + +#include "libguile/_scm.h" +#include "libguile/chars.h" +#include "libguile/eval.h" +#include "libguile/hash.h" +#include "libguile/smob.h" +#include "libguile/variable.h" +#include "libguile/alist.h" +#include "libguile/fluids.h" +#include "libguile/strings.h" +#include "libguile/vectors.h" +#include "libguile/hashtab.h" +#include "libguile/weaks.h" +#include "libguile/modules.h" +#include "libguile/deprecation.h" + +#include "libguile/validate.h" +#include "libguile/symbols.h" + +#ifdef HAVE_STRING_H +#include +#endif + + + +#if SCM_ENABLE_VCELLS + +/* scm_sym2ovcell + * looks up the symbol in an arbitrary obarray. + */ + +SCM +scm_sym2ovcell_soft (SCM sym, SCM obarray) +{ + SCM lsym, z; + scm_sizet hash = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (obarray); + + scm_c_issue_deprecation_warning ("`scm_sym2ovcell_soft' is deprecated. " + "Use hashtables instead."); + + SCM_REDEFER_INTS; + for (lsym = SCM_VELTS (obarray)[hash]; + SCM_NIMP (lsym); + lsym = SCM_CDR (lsym)) + { + z = SCM_CAR (lsym); + if (SCM_EQ_P (SCM_CAR (z), sym)) + { + SCM_REALLOW_INTS; + return z; + } + } + SCM_REALLOW_INTS; + return SCM_BOOL_F; +} + + +SCM +scm_sym2ovcell (SCM sym, SCM obarray) +#define FUNC_NAME "scm_sym2ovcell" +{ + SCM answer; + + scm_c_issue_deprecation_warning ("`scm_sym2ovcell' is deprecated. " + "Use hashtables instead."); + + answer = scm_sym2ovcell_soft (sym, obarray); + if (!SCM_FALSEP (answer)) + return answer; + SCM_MISC_ERROR ("uninterned symbol: ~S", SCM_LIST1 (sym)); + return SCM_UNSPECIFIED; /* not reached */ +} +#undef FUNC_NAME + + +/* Intern a symbol whose name is the LEN characters at NAME in OBARRAY. + + OBARRAY should be a vector of lists, indexed by the name's hash + value, modulo OBARRAY's length. Each list has the form + ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the + value associated with that symbol (in the current module? in the + system module?) + + To "intern" a symbol means: if OBARRAY already contains a symbol by + that name, return its (SYMBOL . VALUE) pair; otherwise, create a + new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the + appropriate list of the OBARRAY, and return the pair. + + If softness is non-zero, don't create a symbol if it isn't already + in OBARRAY; instead, just return #f. + + If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and + return (SYMBOL . SCM_UNDEFINED). */ + + +SCM +scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,unsigned int softness) +{ + SCM symbol = scm_mem2symbol (name, len); + scm_sizet raw_hash = SCM_SYMBOL_HASH (symbol); + scm_sizet hash; + SCM lsym; + + scm_c_issue_deprecation_warning ("`scm_intern_obarray_soft' is deprecated. " + "Use hashtables instead."); + + if (SCM_FALSEP (obarray)) + { + if (softness) + return SCM_BOOL_F; + else + return scm_cons (symbol, SCM_UNDEFINED); + } + + hash = raw_hash % SCM_VECTOR_LENGTH (obarray); + + for (lsym = SCM_VELTS (obarray)[hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) + { + SCM a = SCM_CAR (lsym); + SCM z = SCM_CAR (a); + if (SCM_EQ_P (z, symbol)) + return a; + } + + if (softness) + { + return SCM_BOOL_F; + } + else + { + SCM cell = scm_cons (symbol, SCM_UNDEFINED); + SCM slot = SCM_VELTS (obarray) [hash]; + + SCM_VELTS (obarray) [hash] = scm_cons (cell, slot); + + return cell; + } +} + + +SCM +scm_intern_obarray (const char *name,scm_sizet len,SCM obarray) +{ + scm_c_issue_deprecation_warning ("`scm_intern_obarray' is deprecated. " + "Use hashtables instead."); + + return scm_intern_obarray_soft (name, len, obarray, 0); +} + + +SCM +scm_intern (const char *name,scm_sizet len) +{ + scm_c_issue_deprecation_warning ("`scm_intern' is deprecated. " + "Use scm_c_define or scm_c_lookup instead."); + + { + SCM symbol = scm_mem2symbol (name, len); + SCM var = scm_sym2var (symbol, SCM_BOOL_F, SCM_BOOL_T); + SCM vcell = SCM_VARVCELL (var); + SCM_SETCAR (vcell, symbol); + return vcell; + } +} + + +SCM +scm_intern0 (const char * name) +{ + scm_c_issue_deprecation_warning ("`scm_intern0' is deprecated. " + "Use scm_define or scm_lookup instead."); + + return scm_intern (name, strlen (name)); +} + +/* Intern the symbol named NAME in scm_symhash, and give it the value + VAL. NAME is null-terminated. Use the current top_level lookup + closure to give NAME its value. + */ +SCM +scm_sysintern (const char *name, SCM val) +{ + SCM var; + + scm_c_issue_deprecation_warning ("`scm_sysintern' is deprecated. " + "Use `scm_define' instead."); + + var = scm_c_define (name, val); + return SCM_VARVCELL (var); +} + +SCM +scm_sysintern0 (const char *name) +{ + SCM var; + SCM symbol; + + scm_c_issue_deprecation_warning ("`scm_sysintern0' is deprecated. " + "Use `scm_define' instead."); + + symbol = scm_str2symbol (name); + var = scm_sym2var (symbol, scm_current_module_lookup_closure (), SCM_BOOL_T); + if (var == SCM_BOOL_F) + scm_misc_error ("sysintern0", "can't define variable", symbol); + return SCM_VARVCELL (var); +} + +/* Lookup the value of the symbol named by the nul-terminated string + NAME in the current module. */ +SCM +scm_symbol_value0 (const char *name) +{ + scm_c_issue_deprecation_warning ("`scm_symbol_value0' is deprecated. " + "Use `scm_lookup' instead."); + + return scm_variable_ref (scm_c_lookup (name)); +} + +SCM +scm_sym2vcell (SCM sym, SCM thunk, SCM definep) +{ + SCM var; + + scm_c_issue_deprecation_warning("`scm_sym2vcell' is deprecated. " + "Use `scm_define' or `scm_lookup' instead."); + + var = scm_sym2var (sym, thunk, definep); + if (var == SCM_BOOL_F) + return SCM_BOOL_F; + return SCM_VARVCELL (var); +} + +SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, + (SCM o, SCM s, SCM softp), + "Intern a new symbol in @var{obarray}, a symbol table, with name\n" + "@var{string}.\n\n" + "If @var{obarray} is @code{#f}, use the default system symbol table. If\n" + "@var{obarray} is @code{#t}, the symbol should not be interned in any\n" + "symbol table; merely return the pair (@var{symbol}\n" + ". @var{#}).\n\n" + "The @var{soft?} argument determines whether new symbol table entries\n" + "should be created when the specified symbol is not already present in\n" + "@var{obarray}. If @var{soft?} is specified and is a true value, then\n" + "new entries should not be added for symbols not already present in the\n" + "table; instead, simply return @code{#f}.") +#define FUNC_NAME s_scm_string_to_obarray_symbol +{ + SCM vcell; + SCM answer; + int softness; + + SCM_VALIDATE_STRING (2, s); + SCM_ASSERT (SCM_BOOLP (o) || SCM_VECTORP (o), o, SCM_ARG1, FUNC_NAME); + + scm_c_issue_deprecation_warning ("`string->obarray-symbol' is deprecated. " + "Use hashtables instead."); + + softness = (!SCM_UNBNDP (softp) && !SCM_FALSEP(softp)); + /* iron out some screwy calling conventions */ + if (SCM_FALSEP (o)) + { + /* nothing interesting to do here. */ + return scm_string_to_symbol (s); + } + else if (SCM_EQ_P (o, SCM_BOOL_T)) + o = SCM_BOOL_F; + + vcell = scm_intern_obarray_soft (SCM_STRING_CHARS(s), + SCM_STRING_LENGTH (s), + o, + softness); + if (SCM_FALSEP (vcell)) + return vcell; + answer = SCM_CAR (vcell); + return answer; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0, + (SCM o, SCM s), + "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n" + "unspecified initial value. The symbol table is not modified if a symbol\n" + "with this name is already present.") +#define FUNC_NAME s_scm_intern_symbol +{ + scm_sizet hval; + SCM_VALIDATE_SYMBOL (2,s); + if (SCM_FALSEP (o)) + return SCM_UNSPECIFIED; + + scm_c_issue_deprecation_warning ("`intern-symbol' is deprecated. " + "Use hashtables instead."); + + SCM_VALIDATE_VECTOR (1,o); + hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o); + /* If the symbol is already interned, simply return. */ + SCM_REDEFER_INTS; + { + SCM lsym; + SCM sym; + for (lsym = SCM_VELTS (o)[hval]; + SCM_NIMP (lsym); + lsym = SCM_CDR (lsym)) + { + sym = SCM_CAR (lsym); + if (SCM_EQ_P (SCM_CAR (sym), s)) + { + SCM_REALLOW_INTS; + return SCM_UNSPECIFIED; + } + } + SCM_VELTS (o)[hval] = + scm_acons (s, SCM_UNDEFINED, SCM_VELTS (o)[hval]); + } + SCM_REALLOW_INTS; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0, + (SCM o, SCM s), + "Remove the symbol with name @var{string} from @var{obarray}. This\n" + "function returns @code{#t} if the symbol was present and @code{#f}\n" + "otherwise.") +#define FUNC_NAME s_scm_unintern_symbol +{ + scm_sizet hval; + + scm_c_issue_deprecation_warning ("`unintern-symbol' is deprecated. " + "Use hashtables instead."); + + SCM_VALIDATE_SYMBOL (2,s); + if (SCM_FALSEP (o)) + return SCM_BOOL_F; + SCM_VALIDATE_VECTOR (1,o); + hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o); + SCM_DEFER_INTS; + { + SCM lsym_follow; + SCM lsym; + SCM sym; + for (lsym = SCM_VELTS (o)[hval], lsym_follow = SCM_BOOL_F; + SCM_NIMP (lsym); + lsym_follow = lsym, lsym = SCM_CDR (lsym)) + { + sym = SCM_CAR (lsym); + if (SCM_EQ_P (SCM_CAR (sym), s)) + { + /* Found the symbol to unintern. */ + if (SCM_FALSEP (lsym_follow)) + SCM_VELTS(o)[hval] = lsym; + else + SCM_SETCDR (lsym_follow, SCM_CDR(lsym)); + SCM_ALLOW_INTS; + return SCM_BOOL_T; + } + } + } + SCM_ALLOW_INTS; + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_symbol_binding, "symbol-binding", 2, 0, 0, + (SCM o, SCM s), + "Look up in @var{obarray} the symbol whose name is @var{string}, and\n" + "return the value to which it is bound. If @var{obarray} is @code{#f},\n" + "use the global symbol table. If @var{string} is not interned in\n" + "@var{obarray}, an error is signalled.") +#define FUNC_NAME s_scm_symbol_binding +{ + SCM vcell; + + scm_c_issue_deprecation_warning ("`symbol-binding' is deprecated. " + "Use hashtables instead."); + + SCM_VALIDATE_SYMBOL (2,s); + if (SCM_FALSEP (o)) + return scm_variable_ref (scm_lookup (s)); + SCM_VALIDATE_VECTOR (1,o); + vcell = scm_sym2ovcell (s, o); + return SCM_CDR(vcell); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 2, 0, 0, + (SCM o, SCM s), + "Return @code{#t} if @var{obarray} contains a symbol with name\n" + "@var{string}, and @code{#f} otherwise.") +#define FUNC_NAME s_scm_symbol_interned_p +{ + SCM vcell; + + scm_c_issue_deprecation_warning ("`symbol-interned?' is deprecated. " + "Use hashtables instead."); + + SCM_VALIDATE_SYMBOL (2,s); + if (SCM_FALSEP (o)) + { + SCM var = scm_sym2var (s, SCM_BOOL_F, SCM_BOOL_F); + if (var != SCM_BOOL_F) + return SCM_BOOL_T; + return SCM_BOOL_F; + } + SCM_VALIDATE_VECTOR (1,o); + vcell = scm_sym2ovcell_soft (s, o); + return (SCM_NIMP(vcell) + ? SCM_BOOL_T + : SCM_BOOL_F); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_symbol_bound_p, "symbol-bound?", 2, 0, 0, + (SCM o, SCM s), + "Return @code{#t} if @var{obarray} contains a symbol with name\n" + "@var{string} bound to a defined value. This differs from\n" + "@var{symbol-interned?} in that the mere mention of a symbol\n" + "usually causes it to be interned; @code{symbol-bound?}\n" + "determines whether a symbol has been given any meaningful\n" + "value.") +#define FUNC_NAME s_scm_symbol_bound_p +{ + SCM vcell; + + scm_c_issue_deprecation_warning ("`symbol-bound?' is deprecated. " + "Use hashtables instead."); + + SCM_VALIDATE_SYMBOL (2,s); + if (SCM_FALSEP (o)) + { + SCM var = scm_sym2var (s, SCM_BOOL_F, SCM_BOOL_F); + if (SCM_DEFVARIABLEP (var)) + return SCM_BOOL_T; + return SCM_BOOL_F; + } + SCM_VALIDATE_VECTOR (1,o); + vcell = scm_sym2ovcell_soft (s, o); + return SCM_BOOL (SCM_NIMP (vcell) && !SCM_UNBNDP (SCM_CDR (vcell))); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_symbol_set_x, "symbol-set!", 3, 0, 0, + (SCM o, SCM s, SCM v), + "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n" + "it to @var{value}. An error is signalled if @var{string} is not present\n" + "in @var{obarray}.") +#define FUNC_NAME s_scm_symbol_set_x +{ + SCM vcell; + + scm_c_issue_deprecation_warning ("`symbol-set!' is deprecated. " + "Use the module system instead."); + + SCM_VALIDATE_SYMBOL (2,s); + if (SCM_FALSEP (o)) + { + scm_define (s, v); + return SCM_UNSPECIFIED; + } + SCM_VALIDATE_VECTOR (1,o); + vcell = scm_sym2ovcell (s, o); + SCM_SETCDR (vcell, v); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +#if 0 + +static void +copy_and_prune_obarray (SCM from, SCM to) +{ + int i; + int length = SCM_VECTOR_LENGTH (from); + for (i = 0; i < length; ++i) + { + SCM head = SCM_VELTS (from)[i]; /* GC protection */ + SCM ls = head; + SCM res = SCM_EOL; + SCM *lloc = &res; + while (SCM_NIMP (ls)) + { + if (!SCM_UNBNDP (SCM_CDAR (ls))) + { + *lloc = scm_cons (SCM_CAR (ls), SCM_EOL); + lloc = SCM_CDRLOC (*lloc); + } + ls = SCM_CDR (ls); + } + SCM_VELTS (to)[i] = res; + } +} + + +SCM_DEFINE (scm_builtin_bindings, "builtin-bindings", 0, 0, 0, + (), + "Create and return a copy of the global symbol table, removing all\n" + "unbound symbols.") +#define FUNC_NAME s_scm_builtin_bindings +{ + int length = SCM_VECTOR_LENGTH (scm_symhash); + SCM obarray = scm_c_make_hash_table (length); + + scm_issue_deprecation_warning ("`builtin-bindings' is deprecated. " + "Use the module system instead."); + + copy_and_prune_obarray (scm_symhash, obarray); + return obarray; +} +#undef FUNC_NAME + +#endif + +#define MAX_PREFIX_LENGTH 30 + +static int gentemp_counter; + +SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0, + (SCM prefix, SCM obarray), + "Create a new symbol with a name unique in an obarray.\n" + "The name is constructed from an optional string @var{prefix}\n" + "and a counter value. The default prefix is @code{t}. The\n" + "@var{obarray} is specified as a second optional argument.\n" + "Default is the system obarray where all normal symbols are\n" + "interned. The counter is increased by 1 at each\n" + "call. There is no provision for resetting the counter.") +#define FUNC_NAME s_scm_gentemp +{ + char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; + char *name = buf; + int len, n_digits; + + scm_c_issue_deprecation_warning ("`gentemp' is deprecated. " + "Use `gensym' instead."); + + if (SCM_UNBNDP (prefix)) + { + name[0] = 't'; + len = 1; + } + else + { + SCM_VALIDATE_STRING (1, prefix); + len = SCM_STRING_LENGTH (prefix); + if (len > MAX_PREFIX_LENGTH) + name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); + strncpy (name, SCM_STRING_CHARS (prefix), len); + } + + if (SCM_UNBNDP (obarray)) + return scm_gensym (prefix); + else + SCM_ASSERT ((SCM_VECTORP (obarray) || SCM_WVECTP (obarray)), + obarray, + SCM_ARG2, + FUNC_NAME); + do + n_digits = scm_iint2str (gentemp_counter++, 10, &name[len]); + while (!SCM_FALSEP (scm_intern_obarray_soft (name, + len + n_digits, + obarray, + 1))); + { + SCM vcell = scm_intern_obarray_soft (name, + len + n_digits, + obarray, + 0); + if (name != buf) + scm_must_free (name); + return SCM_CAR (vcell); + } +} +#undef FUNC_NAME + +void +scm_init_symbols_deprecated () +{ + gentemp_counter = 0; +#ifndef SCM_MAGIC_SNARFER +#include "libguile/symbols-deprecated.x" +#endif +} + +#endif /* SCM_ENABLE_VCELLS */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/symbols.c b/libguile/symbols.c index 1bb2778a8..45f5ee982 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -158,264 +158,6 @@ scm_str2symbol (const char *str) return scm_mem2symbol (str, strlen (str)); } - -/* scm_sym2vcell - * looks up the symbol in the symhash table. - */ - -SCM -scm_sym2vcell (SCM sym, SCM thunk, SCM definep) -#define FUNC_NAME "scm_sym2vcell" -{ - if (SCM_NIMP (thunk)) - { - SCM var; - - if (SCM_EVAL_CLOSURE_P (thunk)) - /* Bypass evaluator in the standard case. */ - var = scm_eval_closure_lookup (thunk, sym, definep); - else - var = scm_apply (thunk, sym, scm_cons (definep, scm_listofnull)); - - if (SCM_FALSEP (var)) - return SCM_BOOL_F; - else if (SCM_VARIABLEP (var)) - return SCM_VARVCELL (var); - else - SCM_MISC_ERROR ("strangely interned symbol: ~S", SCM_LIST1 (sym)); - } - else - { - SCM lsym; - scm_sizet hash; - - SCM_DEFER_INTS; - hash = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (scm_symhash); - for (lsym = SCM_VELTS (scm_symhash)[hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) - { - SCM z = SCM_CAR (lsym); - if (SCM_EQ_P (SCM_CAR (z), sym)) - { - SCM_ALLOW_INTS; - return z; - } - } - - if (!SCM_FALSEP (definep)) - { - SCM cell = scm_cons (sym, SCM_UNDEFINED); - SCM slot = SCM_VELTS (scm_symhash) [hash]; - - SCM_VELTS (scm_symhash) [hash] = scm_cons (cell, slot); - - SCM_ALLOW_INTS; - return cell; - } - else - { - SCM_ALLOW_INTS; - return SCM_BOOL_F; - } - } -} -#undef FUNC_NAME - - -/* scm_sym2ovcell - * looks up the symbol in an arbitrary obarray. - */ - -SCM -scm_sym2ovcell_soft (SCM sym, SCM obarray) -{ - SCM lsym, z; - scm_sizet hash = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (obarray); - SCM_REDEFER_INTS; - for (lsym = SCM_VELTS (obarray)[hash]; - SCM_NIMP (lsym); - lsym = SCM_CDR (lsym)) - { - z = SCM_CAR (lsym); - if (SCM_EQ_P (SCM_CAR (z), sym)) - { - SCM_REALLOW_INTS; - return z; - } - } - SCM_REALLOW_INTS; - return SCM_BOOL_F; -} - - -SCM -scm_sym2ovcell (SCM sym, SCM obarray) -#define FUNC_NAME "scm_sym2ovcell" -{ - SCM answer; - answer = scm_sym2ovcell_soft (sym, obarray); - if (!SCM_FALSEP (answer)) - return answer; - SCM_MISC_ERROR ("uninterned symbol: ~S", SCM_LIST1 (sym)); - return SCM_UNSPECIFIED; /* not reached */ -} -#undef FUNC_NAME - - -/* Intern a symbol whose name is the LEN characters at NAME in OBARRAY. - - OBARRAY should be a vector of lists, indexed by the name's hash - value, modulo OBARRAY's length. Each list has the form - ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the - value associated with that symbol (in the current module? in the - system module?) - - To "intern" a symbol means: if OBARRAY already contains a symbol by - that name, return its (SYMBOL . VALUE) pair; otherwise, create a - new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the - appropriate list of the OBARRAY, and return the pair. - - If softness is non-zero, don't create a symbol if it isn't already - in OBARRAY; instead, just return #f. - - If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and - return (SYMBOL . SCM_UNDEFINED). */ - - -SCM -scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,unsigned int softness) -{ - SCM symbol = scm_mem2symbol (name, len); - scm_sizet raw_hash = SCM_SYMBOL_HASH (symbol); - scm_sizet hash; - SCM lsym; - - if (SCM_FALSEP (obarray)) - { - if (softness) - return SCM_BOOL_F; - else - return scm_cons (symbol, SCM_UNDEFINED); - } - - hash = raw_hash % SCM_VECTOR_LENGTH (obarray); - - for (lsym = SCM_VELTS (obarray)[hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) - { - SCM a = SCM_CAR (lsym); - SCM z = SCM_CAR (a); - if (SCM_EQ_P (z, symbol)) - return a; - } - - if (softness) - { - return SCM_BOOL_F; - } - else - { - SCM cell = scm_cons (symbol, SCM_UNDEFINED); - SCM slot = SCM_VELTS (obarray) [hash]; - - SCM_VELTS (obarray) [hash] = scm_cons (cell, slot); - - return cell; - } -} - - -SCM -scm_intern_obarray (const char *name,scm_sizet len,SCM obarray) -{ - return scm_intern_obarray_soft (name, len, obarray, 0); -} - - -SCM -scm_intern (const char *name,scm_sizet len) -{ - return scm_intern_obarray (name, len, scm_symhash); -} - - -SCM -scm_intern0 (const char * name) -{ - return scm_intern (name, strlen (name)); -} - - -/* Intern the symbol named NAME in scm_symhash, NAME is null-terminated. */ -SCM -scm_sysintern0_no_module_lookup (const char *name) -{ - scm_sizet len = strlen (name); - SCM easy_answer; - SCM_DEFER_INTS; - easy_answer = scm_intern_obarray_soft (name, len, scm_symhash, 1); - if (SCM_NIMP (easy_answer)) - { - SCM_ALLOW_INTS; - return easy_answer; - } - else - { - SCM symbol = scm_mem2symbol (name, len); - scm_sizet raw_hash = SCM_SYMBOL_HASH (symbol); - scm_sizet hash = raw_hash % SCM_VECTOR_LENGTH (scm_symhash); - SCM cell = scm_cons (symbol, SCM_UNDEFINED); - SCM slot = SCM_VELTS (scm_symhash) [hash]; - - SCM_VELTS (scm_symhash) [hash] = scm_cons (cell, slot); - SCM_ALLOW_INTS; - return cell; - } -} - -/* Intern the symbol named NAME in scm_symhash, and give it the value - VAL. NAME is null-terminated. Use the current top_level lookup - closure to give NAME its value. - */ -SCM -scm_sysintern (const char *name, SCM val) -{ - SCM vcell = scm_sysintern0 (name); - SCM_SETCDR (vcell, val); - return vcell; -} - -SCM -scm_sysintern0 (const char *name) -{ - SCM lookup_proc; - if (scm_module_system_booted_p - && SCM_NIMP (lookup_proc = SCM_TOP_LEVEL_LOOKUP_CLOSURE)) - { - SCM sym = scm_str2symbol (name); - SCM vcell = scm_sym2vcell (sym, lookup_proc, SCM_BOOL_T); - if (SCM_FALSEP (vcell)) - scm_misc_error ("sysintern0", "can't define variable", sym); - return vcell; - } - else - return scm_sysintern0_no_module_lookup (name); -} - -/* Lookup the value of the symbol named by the nul-terminated string - NAME in the current module. */ -SCM -scm_symbol_value0 (const char *name) -{ - /* This looks silly - we look up the symbol twice. But it is in - fact necessary given the current module system because the module - lookup closures are written in scheme which needs real symbols. */ - SCM symbol = scm_str2symbol (name); - SCM vcell = scm_sym2vcell (symbol, SCM_TOP_LEVEL_LOOKUP_CLOSURE, SCM_BOOL_F); - if (SCM_FALSEP (vcell)) - return SCM_UNDEFINED; - return SCM_CDR (vcell); -} - - SCM_DEFINE (scm_symbol_p, "symbol?", 1, 0, 0, (SCM obj), "Return @code{#t} if @var{obj} is a symbol, otherwise return\n" @@ -489,202 +231,55 @@ SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0, } #undef FUNC_NAME +#define MAX_PREFIX_LENGTH 30 -SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, - (SCM o, SCM s, SCM softp), - "Intern a new symbol in @var{obarray}, a symbol table, with name\n" - "@var{string}.\n\n" - "If @var{obarray} is @code{#f}, use the default system symbol table. If\n" - "@var{obarray} is @code{#t}, the symbol should not be interned in any\n" - "symbol table; merely return the pair (@var{symbol}\n" - ". @var{#}).\n\n" - "The @var{soft?} argument determines whether new symbol table entries\n" - "should be created when the specified symbol is not already present in\n" - "@var{obarray}. If @var{soft?} is specified and is a true value, then\n" - "new entries should not be added for symbols not already present in the\n" - "table; instead, simply return @code{#f}.") -#define FUNC_NAME s_scm_string_to_obarray_symbol -{ - SCM vcell; - SCM answer; - int softness; - - SCM_VALIDATE_STRING (2, s); - SCM_ASSERT (SCM_BOOLP (o) || SCM_VECTORP (o), o, SCM_ARG1, FUNC_NAME); - - softness = (!SCM_UNBNDP (softp) && !SCM_FALSEP(softp)); - /* iron out some screwy calling conventions */ - if (SCM_FALSEP (o)) - o = scm_symhash; - else if (SCM_EQ_P (o, SCM_BOOL_T)) - o = SCM_BOOL_F; - - vcell = scm_intern_obarray_soft (SCM_STRING_CHARS(s), - SCM_STRING_LENGTH (s), - o, - softness); - if (SCM_FALSEP (vcell)) - return vcell; - answer = SCM_CAR (vcell); - return answer; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0, - (SCM o, SCM s), - "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n" - "unspecified initial value. The symbol table is not modified if a symbol\n" - "with this name is already present.") -#define FUNC_NAME s_scm_intern_symbol -{ - scm_sizet hval; - SCM_VALIDATE_SYMBOL (2,s); - if (SCM_FALSEP (o)) - o = scm_symhash; - SCM_VALIDATE_VECTOR (1,o); - hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o); - /* If the symbol is already interned, simply return. */ - SCM_REDEFER_INTS; - { - SCM lsym; - SCM sym; - for (lsym = SCM_VELTS (o)[hval]; - SCM_NIMP (lsym); - lsym = SCM_CDR (lsym)) - { - sym = SCM_CAR (lsym); - if (SCM_EQ_P (SCM_CAR (sym), s)) - { - SCM_REALLOW_INTS; - return SCM_UNSPECIFIED; - } - } - SCM_VELTS (o)[hval] = - scm_acons (s, SCM_UNDEFINED, SCM_VELTS (o)[hval]); - } - SCM_REALLOW_INTS; - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME +static int gensym_counter; -SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0, - (SCM o, SCM s), - "Remove the symbol with name @var{string} from @var{obarray}. This\n" - "function returns @code{#t} if the symbol was present and @code{#f}\n" - "otherwise.") -#define FUNC_NAME s_scm_unintern_symbol +SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, + (SCM prefix), + "Create a new symbol with a name constructed from a prefix and\n" + "a counter value. The string @var{prefix} can be specified as\n" + "an optional argument. Default prefix is @code{g}. The counter\n" + "is increased by 1 at each call. There is no provision for\n" + "resetting the counter.") +#define FUNC_NAME s_scm_gensym { - scm_sizet hval; - SCM_VALIDATE_SYMBOL (2,s); - if (SCM_FALSEP (o)) - o = scm_symhash; - SCM_VALIDATE_VECTOR (1,o); - hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o); - SCM_DEFER_INTS; + char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; + char *name = buf; + int len; + if (SCM_UNBNDP (prefix)) + { + name[0] = 'g'; + len = 1; + } + else + { + SCM_VALIDATE_STRING (1, prefix); + len = SCM_STRING_LENGTH (prefix); + if (len > MAX_PREFIX_LENGTH) + name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); + strncpy (name, SCM_STRING_CHARS (prefix), len); + } { - SCM lsym_follow; - SCM lsym; - SCM sym; - for (lsym = SCM_VELTS (o)[hval], lsym_follow = SCM_BOOL_F; - SCM_NIMP (lsym); - lsym_follow = lsym, lsym = SCM_CDR (lsym)) - { - sym = SCM_CAR (lsym); - if (SCM_EQ_P (SCM_CAR (sym), s)) - { - /* Found the symbol to unintern. */ - if (SCM_FALSEP (lsym_follow)) - SCM_VELTS(o)[hval] = lsym; - else - SCM_SETCDR (lsym_follow, SCM_CDR(lsym)); - SCM_ALLOW_INTS; - return SCM_BOOL_T; - } - } + int n_digits = scm_iint2str (gensym_counter++, 10, &name[len]); + SCM res = scm_mem2symbol (name, len + n_digits); + if (name != buf) + scm_must_free (name); + return res; } - SCM_ALLOW_INTS; - return SCM_BOOL_F; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_symbol_binding, "symbol-binding", 2, 0, 0, - (SCM o, SCM s), - "Look up in @var{obarray} the symbol whose name is @var{string}, and\n" - "return the value to which it is bound. If @var{obarray} is @code{#f},\n" - "use the global symbol table. If @var{string} is not interned in\n" - "@var{obarray}, an error is signalled.") -#define FUNC_NAME s_scm_symbol_binding -{ - SCM vcell; - SCM_VALIDATE_SYMBOL (2,s); - if (SCM_FALSEP (o)) - o = scm_symhash; - SCM_VALIDATE_VECTOR (1,o); - vcell = scm_sym2ovcell (s, o); - return SCM_CDR(vcell); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 2, 0, 0, - (SCM o, SCM s), - "Return @code{#t} if @var{obarray} contains a symbol with name\n" - "@var{string}, and @code{#f} otherwise.") -#define FUNC_NAME s_scm_symbol_interned_p -{ - SCM vcell; - SCM_VALIDATE_SYMBOL (2,s); - if (SCM_FALSEP (o)) - o = scm_symhash; - SCM_VALIDATE_VECTOR (1,o); - vcell = scm_sym2ovcell_soft (s, o); - return (SCM_NIMP(vcell) - ? SCM_BOOL_T - : SCM_BOOL_F); } #undef FUNC_NAME - -SCM_DEFINE (scm_symbol_bound_p, "symbol-bound?", 2, 0, 0, - (SCM o, SCM s), - "Return @code{#t} if @var{obarray} contains a symbol with name\n" - "@var{string} bound to a defined value. This differs from\n" - "@var{symbol-interned?} in that the mere mention of a symbol\n" - "usually causes it to be interned; @code{symbol-bound?}\n" - "determines whether a symbol has been given any meaningful\n" - "value.") -#define FUNC_NAME s_scm_symbol_bound_p -{ - SCM vcell; - SCM_VALIDATE_SYMBOL (2,s); - if (SCM_FALSEP (o)) - o = scm_symhash; - SCM_VALIDATE_VECTOR (1,o); - vcell = scm_sym2ovcell_soft (s, o); - return SCM_BOOL (SCM_NIMP (vcell) && !SCM_UNBNDP (SCM_CDR (vcell))); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_symbol_set_x, "symbol-set!", 3, 0, 0, - (SCM o, SCM s, SCM v), - "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n" - "it to @var{value}. An error is signalled if @var{string} is not present\n" - "in @var{obarray}.") -#define FUNC_NAME s_scm_symbol_set_x +SCM_DEFINE (scm_symbol_hash, "symbol-hash", 1, 0, 0, + (SCM symbol), + "Return a hash value for @var{symbol}.") +#define FUNC_NAME s_scm_symbol_hash { - SCM vcell; - SCM_VALIDATE_SYMBOL (2,s); - if (SCM_FALSEP (o)) - o = scm_symhash; - SCM_VALIDATE_VECTOR (1,o); - vcell = scm_sym2ovcell (s, o); - SCM_SETCDR (vcell, v); - return SCM_UNSPECIFIED; + SCM_VALIDATE_SYMBOL (1, symbol); + return SCM_MAKINUM (SCM_SYMBOL_HASH (symbol)); } #undef FUNC_NAME - SCM_DEFINE (scm_symbol_fref, "symbol-fref", 1, 0, 0, (SCM s), "Return the contents of @var{symbol}'s @dfn{function slot}.") @@ -732,152 +327,6 @@ SCM_DEFINE (scm_symbol_pset_x, "symbol-pset!", 2, 0, 0, } #undef FUNC_NAME - -SCM_DEFINE (scm_symbol_hash, "symbol-hash", 1, 0, 0, - (SCM symbol), - "Return a hash value for @var{symbol}.") -#define FUNC_NAME s_scm_symbol_hash -{ - SCM_VALIDATE_SYMBOL (1, symbol); - return SCM_MAKINUM (SCM_SYMBOL_HASH (symbol)); -} -#undef FUNC_NAME - - -static void -copy_and_prune_obarray (SCM from, SCM to) -{ - int i; - int length = SCM_VECTOR_LENGTH (from); - for (i = 0; i < length; ++i) - { - SCM head = SCM_VELTS (from)[i]; /* GC protection */ - SCM ls = head; - SCM res = SCM_EOL; - SCM *lloc = &res; - while (SCM_NIMP (ls)) - { - if (!SCM_UNBNDP (SCM_CDAR (ls))) - { - *lloc = scm_cons (SCM_CAR (ls), SCM_EOL); - lloc = SCM_CDRLOC (*lloc); - } - ls = SCM_CDR (ls); - } - SCM_VELTS (to)[i] = res; - } -} - - -SCM_DEFINE (scm_builtin_bindings, "builtin-bindings", 0, 0, 0, - (), - "Create and return a copy of the global symbol table, removing all\n" - "unbound symbols.") -#define FUNC_NAME s_scm_builtin_bindings -{ - int length = SCM_VECTOR_LENGTH (scm_symhash); - SCM obarray = scm_c_make_hash_table (length); - copy_and_prune_obarray (scm_symhash, obarray); - return obarray; -} -#undef FUNC_NAME - - -#define MAX_PREFIX_LENGTH 30 - -static int gensym_counter; - -SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, - (SCM prefix), - "Create a new symbol with a name constructed from a prefix and\n" - "a counter value. The string @var{prefix} can be specified as\n" - "an optional argument. Default prefix is @code{g}. The counter\n" - "is increased by 1 at each call. There is no provision for\n" - "resetting the counter.") -#define FUNC_NAME s_scm_gensym -{ - char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; - char *name = buf; - int len; - if (SCM_UNBNDP (prefix)) - { - name[0] = 'g'; - len = 1; - } - else - { - SCM_VALIDATE_STRING (1, prefix); - len = SCM_STRING_LENGTH (prefix); - if (len > MAX_PREFIX_LENGTH) - name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); - strncpy (name, SCM_STRING_CHARS (prefix), len); - } - { - int n_digits = scm_iint2str (gensym_counter++, 10, &name[len]); - SCM res = scm_mem2symbol (name, len + n_digits); - if (name != buf) - scm_must_free (name); - return res; - } -} -#undef FUNC_NAME - -static int gentemp_counter; - -SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0, - (SCM prefix, SCM obarray), - "Create a new symbol with a name unique in an obarray.\n" - "The name is constructed from an optional string @var{prefix}\n" - "and a counter value. The default prefix is @code{t}. The\n" - "@var{obarray} is specified as a second optional argument.\n" - "Default is the system obarray where all normal symbols are\n" - "interned. The counter is increased by 1 at each\n" - "call. There is no provision for resetting the counter.") -#define FUNC_NAME s_scm_gentemp -{ - char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; - char *name = buf; - int len, n_digits; - if (SCM_UNBNDP (prefix)) - { - name[0] = 't'; - len = 1; - } - else - { - SCM_VALIDATE_STRING (1, prefix); - len = SCM_STRING_LENGTH (prefix); - if (len > MAX_PREFIX_LENGTH) - name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); - strncpy (name, SCM_STRING_CHARS (prefix), len); - } - - if (SCM_UNBNDP (obarray)) - obarray = scm_symhash; - else - SCM_ASSERT ((SCM_VECTORP (obarray) || SCM_WVECTP (obarray)), - obarray, - SCM_ARG2, - FUNC_NAME); - do - n_digits = scm_iint2str (gentemp_counter++, 10, &name[len]); - while (!SCM_FALSEP (scm_intern_obarray_soft (name, - len + n_digits, - obarray, - 1))); - { - SCM vcell = scm_intern_obarray_soft (name, - len + n_digits, - obarray, - 0); - if (name != buf) - scm_must_free (name); - return SCM_CAR (vcell); - } -} -#undef FUNC_NAME - - void scm_symbols_prehistory () { @@ -890,10 +339,12 @@ void scm_init_symbols () { gensym_counter = 0; - gentemp_counter = 0; #ifndef SCM_MAGIC_SNARFER #include "libguile/symbols.x" #endif +#if SCM_ENABLE_VCELLS + scm_init_symbols_deprecated (); +#endif } /* diff --git a/libguile/symbols.h b/libguile/symbols.h index a2987aa47..1d10b371e 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -77,35 +77,18 @@ extern SCM scm_sys_symbols (void); extern SCM scm_mem2symbol (const char*, scm_sizet); extern SCM scm_str2symbol (const char*); -extern SCM scm_sym2vcell (SCM sym, SCM thunk, SCM definep); -extern SCM scm_sym2ovcell_soft (SCM sym, SCM obarray); -extern SCM scm_sym2ovcell (SCM sym, SCM obarray); -extern SCM scm_intern_obarray_soft (const char *name, scm_sizet len, SCM obarray, unsigned int softness); -extern SCM scm_intern_obarray (const char *name, scm_sizet len, SCM obarray); -extern SCM scm_intern (const char *name, scm_sizet len); -extern SCM scm_intern0 (const char *name); -extern SCM scm_sysintern (const char *name, SCM val); -extern SCM scm_sysintern0 (const char *name); -extern SCM scm_sysintern0_no_module_lookup (const char *name); -extern SCM scm_symbol_value0 (const char *name); extern SCM scm_symbol_p (SCM x); extern SCM scm_symbol_to_string (SCM s); extern SCM scm_string_to_symbol (SCM s); -extern SCM scm_string_to_obarray_symbol (SCM o, SCM s, SCM softp); -extern SCM scm_intern_symbol (SCM o, SCM s); -extern SCM scm_unintern_symbol (SCM o, SCM s); -extern SCM scm_symbol_binding (SCM o, SCM s); -extern SCM scm_symbol_interned_p (SCM o, SCM s); -extern SCM scm_symbol_bound_p (SCM o, SCM s); -extern SCM scm_symbol_set_x (SCM o, SCM s, SCM v); + extern SCM scm_symbol_fref (SCM s); extern SCM scm_symbol_pref (SCM s); extern SCM scm_symbol_fset_x (SCM s, SCM val); extern SCM scm_symbol_pset_x (SCM s, SCM val); + extern SCM scm_symbol_hash (SCM s); -extern SCM scm_builtin_bindings (void); extern SCM scm_gensym (SCM prefix); -extern SCM scm_gentemp (SCM prefix, SCM obarray); + extern void scm_symbols_prehistory (void); extern void scm_init_symbols (void); @@ -141,6 +124,34 @@ extern void scm_init_symbols (void); #endif /* SCM_DEBUG_DEPRECATED == 0 */ +#if SCM_ENABLE_VCELLS + +extern SCM scm_sym2vcell (SCM sym, SCM thunk, SCM definep); +extern SCM scm_sym2ovcell_soft (SCM sym, SCM obarray); +extern SCM scm_sym2ovcell (SCM sym, SCM obarray); +extern SCM scm_intern_obarray_soft (const char *name, scm_sizet len, SCM obarray, unsigned int softness); +extern SCM scm_intern_obarray (const char *name, scm_sizet len, SCM obarray); +extern SCM scm_intern (const char *name, scm_sizet len); +extern SCM scm_intern0 (const char *name); +extern SCM scm_sysintern (const char *name, SCM val); +extern SCM scm_sysintern0 (const char *name); +extern SCM scm_sysintern0_no_module_lookup (const char *name); +extern SCM scm_symbol_value0 (const char *name); + +extern SCM scm_string_to_obarray_symbol (SCM o, SCM s, SCM softp); +extern SCM scm_intern_symbol (SCM o, SCM s); +extern SCM scm_unintern_symbol (SCM o, SCM s); +extern SCM scm_symbol_binding (SCM o, SCM s); +extern SCM scm_symbol_interned_p (SCM o, SCM s); +extern SCM scm_symbol_bound_p (SCM o, SCM s); +extern SCM scm_symbol_set_x (SCM o, SCM s, SCM v); + +extern SCM scm_gentemp (SCM prefix, SCM obarray); + +extern void scm_init_symbols_deprecated (void); + +#endif /* SCM_ENABLE_VCELLS */ + #endif /* SYMBOLSH */ /* diff --git a/libguile/tag.c b/libguile/tag.c dissimilarity index 100% index 511d1d69f..e69de29bb 100644 --- a/libguile/tag.c +++ b/libguile/tag.c @@ -1,108 +0,0 @@ -/* Copyright (C) 1996, 1997, 2000 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ - -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ - - -#include "libguile/_scm.h" -#include "libguile/chars.h" -#include "libguile/struct.h" - -#include "libguile/tag.h" - - -#define CONST_INUM(c_name, scheme_name, value) \ -SCM_VCELL_INIT(c_name, scheme_name, SCM_MAKINUM (value)) - -CONST_INUM (scm_utag_immediate_integer, "utag_immediate_integer", 0); -CONST_INUM (scm_utag_immediate_char, "utag_immediate_char", 1); -CONST_INUM (scm_utag_pair, "utag_pair", 2); -CONST_INUM (scm_utag_closure, "utag_closure", 3); -CONST_INUM (scm_utag_symbol, "utag_symbol", 4); -CONST_INUM (scm_utag_vector, "utag_vector", 5); -CONST_INUM (scm_utag_wvect, "utag_wvect", 6); - -#ifdef HAVE_ARRAYS -CONST_INUM (scm_utag_bvect, "utag_bvect", 7); -CONST_INUM (scm_utag_byvect, "utag_byvect", 8); -CONST_INUM (scm_utag_svect, "utag_svect", 9); -CONST_INUM (scm_utag_ivect, "utag_ivect", 10); -CONST_INUM (scm_utag_uvect, "utag_uvect", 11); -CONST_INUM (scm_utag_fvect, "utag_fvect", 12); -CONST_INUM (scm_utag_dvect, "utag_dvect", 13); -CONST_INUM (scm_utag_cvect, "utag_cvect", 14); -#endif - -CONST_INUM (scm_utag_string, "utag_string", 15); -CONST_INUM (scm_utag_substring, "utag_substring", 17); -CONST_INUM (scm_utag_asubr, "utag_asubr", 19); -CONST_INUM (scm_utag_subr_0, "utag_subr_0", 20); -CONST_INUM (scm_utag_subr_1, "utag_subr_1", 21); -CONST_INUM (scm_utag_cxr, "utag_cxr", 22); -CONST_INUM (scm_utag_subr_3, "utag_subr_3", 23); -CONST_INUM (scm_utag_subr_2, "utag_subr_2", 24); -CONST_INUM (scm_utag_rpsubr, "utag_rpsubr", 25); -CONST_INUM (scm_utag_subr_1o, "utag_subr_1o", 26); -CONST_INUM (scm_utag_subr_2o, "utag_subr_2o", 27); -CONST_INUM (scm_utag_lsubr_2, "utag_lsubr_2", 28); -CONST_INUM (scm_utag_lsubr, "utag_lsubr", 29); -CONST_INUM (scm_utag_smob_base, "utag_smob_base", 252); -CONST_INUM (scm_utag_port_base, "utag_port_base", 253); -CONST_INUM (scm_utag_flag_base, "utag_flag_base", 254); -CONST_INUM (scm_utag_struct_base, "utag_struct_base", 255); - - - -void -scm_init_tag () -{ -#ifndef SCM_MAGIC_SNARFER -#include "libguile/tag.x" -#endif -} - - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ diff --git a/libguile/throw.c b/libguile/throw.c index 8be37a006..b1f945602 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -292,13 +292,13 @@ scm_internal_lazy_catch (SCM tag, scm_catch_body_t body, void *body_data, scm_ca /* scm_internal_stack_catch Use this one if you want debugging information to be stored in - scm_the_last_stack_fluid on error. */ + scm_the_last_stack_fluid_var on error. */ static SCM ss_handler (void *data, SCM tag, SCM throw_args) { /* Save the stack */ - scm_fluid_set_x (SCM_CDR (scm_the_last_stack_fluid), + scm_fluid_set_x (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var), scm_make_stack (SCM_BOOL_T, SCM_EOL)); /* Throw the error */ return scm_throw (tag, throw_args); diff --git a/libguile/variable.c b/libguile/variable.c index 064744f73..4c0ad5a04 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -49,6 +49,7 @@ #include "libguile/ports.h" #include "libguile/root.h" #include "libguile/smob.h" +#include "libguile/deprecation.h" #include "libguile/validate.h" #include "libguile/variable.h" @@ -60,16 +61,8 @@ variable_print (SCM exp, SCM port, scm_print_state *pstate) { scm_puts ("#', port); return 1; } @@ -77,55 +70,40 @@ variable_print (SCM exp, SCM port, scm_print_state *pstate) static SCM variable_equalp (SCM var1, SCM var2) { - return scm_equal_p (SCM_VARVCELL (var1), SCM_VARVCELL (var2)); + return scm_equal_p (SCM_VARIABLE_REF (var1), SCM_VARIABLE_REF (var2)); } -SCM_SYMBOL (anonymous_variable_sym, "anonymous-variable"); - +#if SCM_ENABLE_VCELLS +SCM_SYMBOL (sym_huh, "???"); +#endif static SCM -make_vcell_variable (SCM vcell) +make_variable (SCM init) { - SCM_RETURN_NEWSMOB (scm_tc16_variable, SCM_UNPACK (vcell)); +#if !SCM_ENABLE_VCELLS + SCM_RETURN_NEWSMOB (scm_tc16_variable, SCM_UNPACK (init)); +#else + SCM_RETURN_NEWSMOB (scm_tc16_variable, scm_cons (sym_huh, init)); +#endif } -SCM_DEFINE (scm_make_variable, "make-variable", 1, 1, 0, - (SCM init, SCM name_hint), - "Return a variable object initialized to value @var{init}.\n" - "If given, uses @var{name-hint} as its internal (debugging)\n" - "name, otherwise just treat it as an anonymous variable.\n" - "Remember, of course, that multiple bindings to the same\n" - "variable may exist, so @var{name-hint} is just that---a hint.\n") +SCM_DEFINE (scm_make_variable, "make-variable", 1, 0, 0, + (SCM init), + "Return a variable initialized to value @var{init}.\n") #define FUNC_NAME s_scm_make_variable { - SCM vcell; - - if (SCM_UNBNDP (name_hint)) - name_hint = anonymous_variable_sym; - - vcell = scm_cons (name_hint, init); - return make_vcell_variable (vcell); + return make_variable (init); } #undef FUNC_NAME -SCM_DEFINE (scm_make_undefined_variable, "make-undefined-variable", 0, 1, 0, - (SCM name_hint), - "Return a variable object initialized to an undefined value.\n" - "If given, uses @var{name-hint} as its internal (debugging)\n" - "name, otherwise just treat it as an anonymous variable.\n" - "Remember, of course, that multiple bindings to the same\n" - "variable may exist, so @var{name-hint} is just that---a hint.\n") +SCM_DEFINE (scm_make_undefined_variable, "make-undefined-variable", 0, 0, 0, + (), + "Return a variable that is initially unbound.\n") #define FUNC_NAME s_scm_make_undefined_variable { - SCM vcell; - - if (SCM_UNBNDP (name_hint)) - name_hint = anonymous_variable_sym; - - vcell = scm_cons (name_hint, SCM_UNDEFINED); - return make_vcell_variable (vcell); + return make_variable (SCM_UNDEFINED); } #undef FUNC_NAME @@ -148,13 +126,15 @@ SCM_DEFINE (scm_variable_ref, "variable-ref", 1, 0, 0, "and @code{make-undefined-variable}.") #define FUNC_NAME s_scm_variable_ref { + SCM val; SCM_VALIDATE_VARIABLE (1, var); - return SCM_CDR (SCM_VARVCELL (var)); + val = SCM_VARIABLE_REF (var); + if (val == SCM_UNDEFINED) + SCM_MISC_ERROR ("variable is unbound: ~S", SCM_LIST1 (var)); + return val; } #undef FUNC_NAME - - SCM_DEFINE (scm_variable_set_x, "variable-set!", 2, 0, 0, (SCM var, SCM val), "Set the value of the variable @var{var} to @var{val}.\n" @@ -163,41 +143,11 @@ SCM_DEFINE (scm_variable_set_x, "variable-set!", 2, 0, 0, #define FUNC_NAME s_scm_variable_set_x { SCM_VALIDATE_VARIABLE (1, var); - SCM_SETCDR (SCM_VARVCELL (var), val); + SCM_VARIABLE_SET (var, val); return SCM_UNSPECIFIED; } #undef FUNC_NAME - -SCM_DEFINE (scm_builtin_variable, "builtin-variable", 1, 0, 0, - (SCM name), - "Return the built-in variable with the name @var{name}.\n" - "@var{name} must be a symbol (not a string).\n" - "Then use @code{variable-ref} to access its value.\n") -#define FUNC_NAME s_scm_builtin_variable -{ - SCM vcell; - SCM var_slot; - - SCM_VALIDATE_SYMBOL (1,name); - vcell = scm_sym2vcell (name, SCM_BOOL_F, SCM_BOOL_T); - if (SCM_FALSEP (vcell)) - return SCM_BOOL_F; - - scm_intern_symbol (scm_symhash_vars, name); - var_slot = scm_sym2ovcell (name, scm_symhash_vars); - - SCM_DEFER_INTS; - if (SCM_IMP (SCM_CDR (var_slot)) - || !SCM_EQ_P (SCM_VARVCELL (var_slot), vcell)) - SCM_SETCDR (var_slot, make_vcell_variable (vcell)); - SCM_ALLOW_INTS; - - return SCM_CDR (var_slot); -} -#undef FUNC_NAME - - SCM_DEFINE (scm_variable_bound_p, "variable-bound?", 1, 0, 0, (SCM var), "Return @code{#t} iff @var{var} is bound to a value.\n" @@ -205,12 +155,41 @@ SCM_DEFINE (scm_variable_bound_p, "variable-bound?", 1, 0, 0, #define FUNC_NAME s_scm_variable_bound_p { SCM_VALIDATE_VARIABLE (1, var); - return SCM_BOOL (!SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (var)))); + return SCM_BOOL (SCM_VARIABLE_REF (var) != SCM_UNDEFINED); } #undef FUNC_NAME +SCM_DEFINE (scm_variable_set_name_hint, "variable-set-name-hint!", 2, 0, 0, + (SCM var, SCM hint), + "Do not use this function.") +#define FUNC_NAME s_scm_variable_set_name_hint +{ + SCM_VALIDATE_VARIABLE (1, var); + SCM_VALIDATE_SYMBOL (2, hint); +#if SCM_ENABLE_VCELLS + SCM_SETCAR (SCM_SMOB_DATA (var), hint); +#endif + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME +#if SCM_ENABLE_VCELLS +SCM_DEFINE (scm_builtin_variable, "builtin-variable", 1, 0, 0, + (SCM name), + "Return the built-in variable with the name @var{name}.\n" + "@var{name} must be a symbol (not a string).\n" + "Then use @code{variable-ref} to access its value.\n") +#define FUNC_NAME s_scm_builtin_variable +{ + SCM_VALIDATE_SYMBOL (1,name); + scm_c_issue_deprecation_warning ("`builtin-variable' is deprecated. " + "Use module system operations instead."); + return scm_sym2var (name, SCM_BOOL_F, SCM_BOOL_T); +} +#undef FUNC_NAME + +#endif /* SCM_ENABLE_VCELLS */ void scm_init_variable () @@ -225,7 +204,6 @@ scm_init_variable () #endif } - /* Local Variables: c-file-style: "gnu" diff --git a/libguile/variable.h b/libguile/variable.h index f5fc686ed..f899658a4 100644 --- a/libguile/variable.h +++ b/libguile/variable.h @@ -47,6 +47,7 @@ gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include "libguile/__scm.h" +#include "libguile/smob.h" @@ -55,20 +56,35 @@ */ extern scm_bits_t scm_tc16_variable; -#define SCM_VARVCELL(V) SCM_CELL_OBJECT_1 (V) -#define SCM_VARIABLEP(X) (!SCM_IMP (X) && SCM_CELL_TYPE (X) == scm_tc16_variable) -#define SCM_UDVARIABLEP(X) (SCM_VARIABLEP(X) && SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X)))) -#define SCM_DEFVARIABLEP(X) (SCM_VARIABLEP(X) && !SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X)))) +#define SCM_VARIABLEP(X) SCM_SMOB_PREDICATE (scm_tc16_variable, X) + +#if !SCM_ENABLE_VCELLS +#define SCM_VARIABLE_REF(V) SCM_CELL_OBJECT_1(V) +#define SCM_VARIABLE_SET(V,X) SCM_SET_CELL_OBJECT_1 (V, X) +#define SCM_VARIABLE_LOC(V) ((SCM *) SCM_CELL_WORD_LOC ((V), 1)) +#else +#define SCM_VARVCELL(V) SCM_CELL_OBJECT_1(V) +#define SCM_UDVARIABLEP(X) (SCM_VARIABLEP(X) && SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X)))) +#define SCM_DEFVARIABLEP(X) (SCM_VARIABLEP(X) && !SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X)))) + +#define SCM_VARIABLE_REF(V) SCM_CDR(SCM_VARVCELL(V)) +#define SCM_VARIABLE_SET(V,X) SCM_SETCDR(SCM_VARVCELL(V),X) +#define SCM_VARIABLE_LOC(V) SCM_CDRLOC(SCM_VARVCELL(V)) +#endif -extern SCM scm_make_variable (SCM init, SCM name_hint); -extern SCM scm_make_undefined_variable (SCM name_hint); +extern SCM scm_make_variable (SCM init); +extern SCM scm_make_undefined_variable (void); extern SCM scm_variable_p (SCM obj); extern SCM scm_variable_ref (SCM var); extern SCM scm_variable_set_x (SCM var, SCM val); -extern SCM scm_builtin_variable (SCM name); extern SCM scm_variable_bound_p (SCM var); +extern SCM scm_variable_set_name_hint (SCM var, SCM hint); +#if SCM_ENABLE_VCELLS +extern SCM scm_builtin_variable (SCM name); +#endif + extern void scm_init_variable (void); #endif /* SCM_VARIABLE_H */ -- 2.20.1