mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

Merge from mvo-vcell-cleanup-1-branch.

Browse source
This commit is contained in:
Marius Vollmer 2001-05-15 14:57:22 +00:00
parent 7c33806ae6
commit 86d31dfe7d
54 changed files with 1538 additions and 1293 deletions
Download patch file Download diff file Expand all files Collapse all files

29
libguile/Makefile.am
View file

@ -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@

9
libguile/__scm.h
View file

@ -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

2
libguile/_scm.h
View file

@ -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

13
libguile/backtrace.c
View file

@ -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"

2
libguile/backtrace.h
View file

@ -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);

2
libguile/cpp_cnvt.awk
View file

@ -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"
}

48
libguile/debug.c
View file

@ -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");

4
libguile/deprecation.c
View file

@ -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

3
libguile/dynwind.c
View file

@ -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);

205
libguile/eval.c
View file

@ -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");
}

14
libguile/eval.h
View file

@ -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)))

25
libguile/evalext.c
View file

@ -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

10
libguile/feature.c
View file

@ -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"

38
libguile/filesys.c
View file

@ -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

6
libguile/fports.c
View file

@ -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"

102
libguile/gc.c
View file

@ -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);

6
libguile/gdbint.c
View file

@ -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;

8
libguile/gh_data.c
View file

@ -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;
}

3
libguile/gh_funcs.c
View file

@ -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;
}

13
libguile/goops.c
View file

@ -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

8
libguile/gsubr.c
View file

@ -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;
}

2
libguile/hooks.c
View file

@ -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;
}

5
libguile/init.c
View file

@ -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 ();

13
libguile/keywords.c
View file

@ -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

12
libguile/load.c
View file

@ -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 ();

6
libguile/macros.c
View file

@ -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

339
libguile/modules.c
View file

@ -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;
}

23
libguile/modules.h
View file

@ -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 */

6
libguile/numbers.c
View file

@ -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");

6
libguile/objects.c
View file

@ -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"

6
libguile/ports.c
View file

@ -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);

46
libguile/posix.c
View file

@ -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"

3
libguile/print.c
View file

@ -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))

17
libguile/procs.c
View file

@ -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;
}

11
libguile/ramap.c
View file

@ -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;
}
}

18
libguile/random.c
View file

@ -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)));
}

2
libguile/read.c
View file

@ -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

12
libguile/regex-posix.c
View file

@ -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"

22
libguile/root.h
View file

@ -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[];

14
libguile/scmsigs.c
View file

@ -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

2
libguile/script.c
View file

@ -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))

26
libguile/snarf.h
View file

@ -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

72
libguile/socket.c
View file

@ -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");

2
libguile/srcprop.c
View file

@ -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"

6
libguile/stacks.c
View file

@ -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;
}

2
libguile/stime.c
View file

@ -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

9
libguile/struct.c
View file

@ -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

637
libguile/symbols-deprecated.c Normal file
View file

@ -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:
*/

631
libguile/symbols.c
View file

@ -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
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
{
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;
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;
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]);
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_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_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_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;
{
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;
SCM_VALIDATE_SYMBOL (1, symbol);
return SCM_MAKINUM (SCM_SYMBOL_HASH (symbol));
}
#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 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;
}
#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
}
/*

51
libguile/symbols.h
View file

@ -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 */
/*

108
libguile/tag.c
View file

@ -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:
*/

4
libguile/throw.c
View file

@ -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);

136
libguile/variable.c
View file

@ -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"

30
libguile/variable.h
View file

@ -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 */