summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
Diffstat (limited to 'libguile')
-rw-r--r--libguile/Makefile.am29
-rw-r--r--libguile/__scm.h9
-rw-r--r--libguile/_scm.h2
-rw-r--r--libguile/backtrace.c13
-rw-r--r--libguile/backtrace.h2
-rw-r--r--libguile/cpp_cnvt.awk2
-rw-r--r--libguile/debug.c48
-rw-r--r--libguile/deprecation.c4
-rw-r--r--libguile/dynwind.c3
-rw-r--r--libguile/eval.c207
-rw-r--r--libguile/eval.h14
-rw-r--r--libguile/evalext.c25
-rw-r--r--libguile/feature.c10
-rw-r--r--libguile/filesys.c38
-rw-r--r--libguile/fports.c6
-rw-r--r--libguile/gc.c102
-rw-r--r--libguile/gdbint.c6
-rw-r--r--libguile/gh_data.c8
-rw-r--r--libguile/gh_funcs.c3
-rw-r--r--libguile/goops.c13
-rw-r--r--libguile/gsubr.c8
-rw-r--r--libguile/hooks.c2
-rw-r--r--libguile/init.c5
-rw-r--r--libguile/keywords.c13
-rw-r--r--libguile/load.c12
-rw-r--r--libguile/macros.c6
-rw-r--r--libguile/modules.c339
-rw-r--r--libguile/modules.h23
-rw-r--r--libguile/numbers.c6
-rw-r--r--libguile/objects.c6
-rw-r--r--libguile/ports.c6
-rw-r--r--libguile/posix.c46
-rw-r--r--libguile/print.c3
-rw-r--r--libguile/procs.c17
-rw-r--r--libguile/ramap.c11
-rw-r--r--libguile/random.c18
-rw-r--r--libguile/read.c2
-rw-r--r--libguile/regex-posix.c12
-rw-r--r--libguile/root.h22
-rw-r--r--libguile/scmsigs.c14
-rw-r--r--libguile/script.c2
-rw-r--r--libguile/snarf.h26
-rw-r--r--libguile/socket.c72
-rw-r--r--libguile/srcprop.c2
-rw-r--r--libguile/stacks.c6
-rw-r--r--libguile/stime.c2
-rw-r--r--libguile/struct.c9
-rw-r--r--libguile/symbols-deprecated.c637
-rw-r--r--libguile/symbols.c629
-rw-r--r--libguile/symbols.h51
-rw-r--r--libguile/tag.c108
-rw-r--r--libguile/throw.c4
-rw-r--r--libguile/variable.c136
-rw-r--r--libguile/variable.h30
54 files changed, 1537 insertions, 1292 deletions
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 ("<class>", mt);
+ scm_c_define ("<class>", mt);
scm_metaclass_standard = mt;
- scm_sysintern ("<operator-class>", ot);
+ scm_c_define ("<operator-class>", 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 ("<entity>", et);
+ scm_c_define ("<entity>", 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 <string.h>
+#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{#<undefined>}).\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{#<undefined>}).\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
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 ("#<variable ", port);
scm_intprint (SCM_UNPACK (exp), 16, port);
- {
- SCM vcell = SCM_VARVCELL (exp);
- if (!SCM_UNBNDP (SCM_CAR (vcell)))
- {
- scm_puts (" name: ", port);
- scm_iprin1 (SCM_CAR (vcell), port, pstate);
- }
- scm_puts (" binding: ", port);
- scm_iprin1 (SCM_CDR (vcell), port, pstate);
- }
+ scm_puts (" binding: ", port);
+ scm_iprin1 (SCM_VARIABLE_REF (exp), port, pstate);
scm_putc('>', 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 */