mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-01 01:40:21 +02:00
* tags.h: Update tag system docs.
(scm_tc3_cons_gloc): Renamed to scm_tc3_struct. Changed all uses. (scm_tcs_cons_gloc): Renamed to scm_tcs_struct. Changed all uses. (SCM_ECONSP, SCM_NECONSP): Removed. Changed all uses to SCM_CONSP or SCM_NCONSP, respectively. * struct.c, struct.h, srcprop.c, procs.c, procprop.c, print.c, objects.c. modules.c, goops.c, eval.c, debug.c: Changed all uses of scm_tc3_cond_gloc and scm_tcs_cons_gloc. See above. * print.c (scm_iprin1): Remove printing of glocs. Do not try to tell glocs from structs. * gc.c (scm_gc_mark, scm_gc_sweep): Remove handling of glocs. * eval.c (scm_m_atbind): Make a list of variables, not glocs. (scm_ceval, scm_deval): For SCM_IM_BIND, fiddle with variables instead of with glocs. (EVALCAR): Do not test for glocs. (scm_lookupcar, scm_lookupcar1): Do not handle glocs in race condition. (scm_unmemocar): Do not handle glocs. (scm_m_atfop): Memoize as a variable, not as a gloc. (scm_eval_args, scm_deval_args): Do not handle glocs. (scm_ceval, scm_deval): Likewise. * eval.h (SCM_XEVALCAR): Do not test for glocs. (SCM_GLOC_VAR, SCM_GLOC_VAL, SCM_GLOC_SET_VAL, SCM_GLOC_VAL_LOC): Removed. * debug.h, debug.c (scm_make_gloc, scm_gloc_p): Removed. * dynwind.c (scm_swap_bindings): Likewise. (scm_dowinds): Updated to recognize lists of variables instead of lists of glocs. * __scm.h (SCM_CAUTIOS, SCM_RECKLESS): Update comments.
This commit is contained in:
Marius Vollmer
parent
5b54c4daa1
commit
904a077df1
17 changed files with 201 additions and 391 deletions
|
|
@ -100,11 +100,12 @@
|
|||
/* If the compile FLAG `SCM_CAUTIOUS' is #defined then the number of
|
||||
* arguments is always checked for application of closures. If the
|
||||
* compile FLAG `SCM_RECKLESS' is #defined then they are not checked.
|
||||
* Otherwise, number of argument checks for closures are made only when
|
||||
* the function position (whose value is the closure) of a combination is
|
||||
* not an ILOC or GLOC. When the function position of a combination is a
|
||||
* symbol it will be checked only the first time it is evaluated because
|
||||
* it will then be replaced with an ILOC or GLOC.
|
||||
* Otherwise, number of argument checks for closures are made only
|
||||
* when the function position (whose value is the closure) of a
|
||||
* combination is not an ILOC or a variable (true?). When the
|
||||
* function position of a combination is a symbol it will be checked
|
||||
* only the first time it is evaluated because it will then be
|
||||
* replaced with an ILOC or variable.
|
||||
*/
|
||||
#undef SCM_RECKLESS
|
||||
#define SCM_CAUTIOUS
|
||||
|
|
|
|||
|
|
@ -196,17 +196,6 @@ scm_make_memoized (SCM exp, SCM env)
|
|||
* specified, the top-level environment of the current module will
|
||||
* be assumed. All environments must match.
|
||||
*
|
||||
* - procedure: make-gloc VARIABLE [ENV]
|
||||
*
|
||||
* Return a gloc, encapsulated in a memoized object.
|
||||
*
|
||||
* (Glocs can't exist in normal list structures, since they will
|
||||
* be mistaken for structs.)
|
||||
*
|
||||
* - procedure: gloc? OBJECT
|
||||
*
|
||||
* Return #t if OBJECT is a memoized gloc.
|
||||
*
|
||||
* - procedure: make-iloc FRAME BINDING CDRP
|
||||
*
|
||||
* Return an iloc referring to frame no. FRAME, binding
|
||||
|
|
@ -252,32 +241,6 @@ scm_make_memoized (SCM exp, SCM env)
|
|||
#include "libguile/variable.h"
|
||||
#include "libguile/procs.h"
|
||||
|
||||
SCM_DEFINE (scm_make_gloc, "make-gloc", 1, 1, 0,
|
||||
(SCM var, SCM env),
|
||||
"Create a gloc for variable @var{var} in the environment\n"
|
||||
"@var{env}.")
|
||||
#define FUNC_NAME s_scm_make_gloc
|
||||
{
|
||||
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_PACK (SCM_UNPACK (var) + scm_tc3_cons_gloc), env);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_gloc_p, "gloc?", 1, 0, 0,
|
||||
(SCM obj),
|
||||
"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) == scm_tc3_cons_gloc));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_make_iloc, "make-iloc", 3, 0, 0,
|
||||
(SCM frame, SCM binding, SCM cdrp),
|
||||
"Return a new iloc with frame offset @var{frame}, binding\n"
|
||||
|
|
@ -538,8 +501,8 @@ scm_m_start_stack (SCM exp, SCM env)
|
|||
#define FUNC_NAME s_start_stack
|
||||
{
|
||||
exp = SCM_CDR (exp);
|
||||
if (!SCM_ECONSP (exp)
|
||||
|| !SCM_ECONSP (SCM_CDR (exp))
|
||||
if (!SCM_CONSP (exp)
|
||||
|| !SCM_CONSP (SCM_CDR (exp))
|
||||
|| !SCM_NULLP (SCM_CDDR (exp)))
|
||||
SCM_WRONG_NUM_ARGS ();
|
||||
return scm_start_stack (scm_eval_car (exp, env), SCM_CADR (exp), env);
|
||||
|
|
|
|||
|
|
@ -209,8 +209,6 @@ extern SCM scm_make_debugobj (scm_t_debug_frame *debug);
|
|||
extern void scm_init_debug (void);
|
||||
|
||||
#ifdef GUILE_DEBUG
|
||||
extern SCM scm_make_gloc (SCM var, SCM env);
|
||||
extern SCM scm_gloc_p (SCM obj);
|
||||
extern SCM scm_make_iloc (SCM frame, SCM binding, SCM cdrp);
|
||||
extern SCM scm_iloc_p (SCM obj);
|
||||
extern SCM scm_memcons (SCM car, SCM cdr, SCM env);
|
||||
|
|
|
|||
|
|
@ -185,15 +185,15 @@ SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0,
|
|||
#endif
|
||||
|
||||
static void
|
||||
scm_swap_bindings (SCM glocs, SCM vals)
|
||||
scm_swap_bindings (SCM vars, SCM vals)
|
||||
{
|
||||
SCM tmp;
|
||||
while (SCM_NIMP (vals))
|
||||
{
|
||||
tmp = SCM_GLOC_VAL (SCM_CAR (glocs));
|
||||
SCM_GLOC_SET_VAL (SCM_CAR (glocs), SCM_CAR (vals));
|
||||
tmp = SCM_VARIABLE_REF (SCM_CAR (vars));
|
||||
SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals));
|
||||
SCM_SETCAR (vals, tmp);
|
||||
glocs = SCM_CDR (glocs);
|
||||
vars = SCM_CDR (vars);
|
||||
vals = SCM_CDR (vals);
|
||||
}
|
||||
}
|
||||
|
|
@ -219,13 +219,16 @@ scm_dowinds (SCM to, long delta)
|
|||
#endif
|
||||
{
|
||||
wind_key = SCM_CAR (wind_elt);
|
||||
/* key = #t | symbol | thunk | list of glocs | list of fluids */
|
||||
/* key = #t | symbol | thunk | list of variables | list of fluids */
|
||||
if (SCM_NIMP (wind_key))
|
||||
{
|
||||
if (SCM_TYP3 (wind_key) == scm_tc3_cons_gloc)
|
||||
scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
|
||||
else if (SCM_TYP3 (wind_key) == scm_tc3_cons)
|
||||
scm_swap_fluids (wind_key, SCM_CDR (wind_elt));
|
||||
if (SCM_CONSP (wind_key))
|
||||
{
|
||||
if (SCM_VARIABLEP (SCM_CAR (wind_key)))
|
||||
scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
|
||||
else if (SCM_FLUIDP (SCM_CAR (wind_key)))
|
||||
scm_swap_fluids (wind_key, SCM_CDR (wind_elt));
|
||||
}
|
||||
else if (SCM_GUARDSP (wind_key))
|
||||
SCM_BEFORE_GUARD (wind_key) (SCM_GUARD_DATA (wind_key));
|
||||
else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
|
||||
|
|
@ -254,10 +257,13 @@ scm_dowinds (SCM to, long delta)
|
|||
wind_key = SCM_CAR (wind_elt);
|
||||
if (SCM_NIMP (wind_key))
|
||||
{
|
||||
if (SCM_TYP3 (wind_key) == scm_tc3_cons_gloc)
|
||||
scm_swap_bindings (wind_key, from);
|
||||
else if (SCM_TYP3 (wind_key) == scm_tc3_cons)
|
||||
scm_swap_fluids_reverse (wind_key, from);
|
||||
if (SCM_CONSP (wind_key))
|
||||
{
|
||||
if (SCM_VARIABLEP (SCM_CAR (wind_key)))
|
||||
scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
|
||||
else if (SCM_FLUIDP (SCM_CAR (wind_key)))
|
||||
scm_swap_fluids_reverse (wind_key, SCM_CDR (wind_elt));
|
||||
}
|
||||
else if (SCM_GUARDSP (wind_key))
|
||||
SCM_AFTER_GUARD (wind_key) (SCM_GUARD_DATA (wind_key));
|
||||
else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
|
||||
|
|
|
|||
176
libguile/eval.c
176
libguile/eval.c
|
|
@ -156,10 +156,8 @@ char *alloca ();
|
|||
: SCM_CEVAL (SCM_CAR (x), env))
|
||||
|
||||
#define EVALCAR(x, env) (!SCM_CELLP (SCM_CAR (x)) \
|
||||
? (SCM_IMP (SCM_CAR (x)) \
|
||||
? SCM_EVALIM (SCM_CAR (x), env) \
|
||||
: SCM_GLOC_VAL (SCM_CAR (x))) \
|
||||
: EVALCELLCAR (x, env))
|
||||
? SCM_EVALIM (SCM_CAR (x), env) \
|
||||
: EVALCELLCAR (x, env))
|
||||
|
||||
#define EXTEND_ENV SCM_EXTEND_ENV
|
||||
|
||||
|
|
@ -197,7 +195,7 @@ scm_ilookup (SCM iloc, SCM env)
|
|||
tree-code instructions.
|
||||
|
||||
There shouldn't normally be a problem with memoizing local and
|
||||
global variable references (into ilocs and glocs), because all
|
||||
global variable references (into ilocs and variables), because all
|
||||
threads will mutate the code in *exactly* the same way and (if I
|
||||
read the C code correctly) it is not possible to observe a half-way
|
||||
mutated cons cell. The lookup procedure can handle this
|
||||
|
|
@ -205,11 +203,11 @@ scm_ilookup (SCM iloc, SCM env)
|
|||
|
||||
It is different with macro expansion, because macro expansion
|
||||
happens outside of the lookup procedure and can't be
|
||||
undone. Therefore it can't cope with it. It has to indicate
|
||||
failure when it detects a lost race and hope that the caller can
|
||||
handle it. Luckily, it turns out that this is the case.
|
||||
undone. Therefore the lookup procedure can't cope with it. It has
|
||||
to indicate failure when it detects a lost race and hope that the
|
||||
caller can handle it. Luckily, it turns out that this is the case.
|
||||
|
||||
An example to illustrate this: Suppose that the follwing form will
|
||||
An example to illustrate this: Suppose that the following form will
|
||||
be memoized concurrently by two threads
|
||||
|
||||
(let ((x 12)) x)
|
||||
|
|
@ -226,13 +224,13 @@ scm_ilookup (SCM iloc, SCM env)
|
|||
But let's see what will happen when the race occurs while looking
|
||||
up the symbol "let" at the start of the form. It could happen that
|
||||
the second thread interrupts the lookup of the first thread and not
|
||||
only substitutes a gloc for it but goes right ahead and replaces it
|
||||
with the compiled form (#@let* (x 12) x). Now, when the first
|
||||
thread completes its lookup, it would replace the #@let* with a
|
||||
gloc pointing to the "let" binding, effectively reverting the form
|
||||
to (let (x 12) x). This is wrong. It has to detect that it has
|
||||
lost the race and the evaluator has to reconsider the changed form
|
||||
completely.
|
||||
only substitutes a variable for it but goes right ahead and
|
||||
replaces it with the compiled form (#@let* (x 12) x). Now, when
|
||||
the first thread completes its lookup, it would replace the #@let*
|
||||
with a variable containing the "let" binding, effectively reverting
|
||||
the form to (let (x 12) x). This is wrong. It has to detect that
|
||||
it has lost the race and the evaluator has to reconsider the
|
||||
changed form completely.
|
||||
|
||||
This race condition could be resolved with some kind of traffic
|
||||
light (like mutexes) around scm_lookupcar, but I think that it is
|
||||
|
|
@ -370,15 +368,13 @@ scm_lookupcar (SCM vloc, SCM genv, int check)
|
|||
completely. */
|
||||
race:
|
||||
var = SCM_CAR (vloc);
|
||||
if (SCM_ITAG3 (var) == scm_tc3_cons_gloc)
|
||||
return SCM_GLOC_VAL_LOC (var);
|
||||
if (SCM_VARIABLEP (var))
|
||||
return SCM_VARIABLE_LOC (var);
|
||||
#ifdef MEMOIZE_LOCALS
|
||||
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
|
||||
/* We can't cope with anything else than variables 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
|
||||
|
|
@ -415,15 +411,7 @@ scm_unmemocar (SCM form, SCM env)
|
|||
if (SCM_IMP (form))
|
||||
return form;
|
||||
c = SCM_CAR (form);
|
||||
if (SCM_ITAG3 (c) == scm_tc3_cons_gloc)
|
||||
{
|
||||
SCM sym =
|
||||
scm_module_reverse_lookup (scm_env_module (env), SCM_GLOC_VAR (c));
|
||||
if (SCM_EQ_P (sym, SCM_BOOL_F))
|
||||
sym = sym_three_question_marks;
|
||||
SCM_SETCAR (form, sym);
|
||||
}
|
||||
else if (SCM_VARIABLEP (c))
|
||||
if (SCM_VARIABLEP (c))
|
||||
{
|
||||
SCM sym =
|
||||
scm_module_reverse_lookup (scm_env_module (env), c);
|
||||
|
|
@ -839,7 +827,7 @@ iqq (SCM form, SCM env, long depth)
|
|||
--depth;
|
||||
label:
|
||||
form = SCM_CDR (form);
|
||||
SCM_ASSERT (SCM_ECONSP (form) && SCM_NULLP (SCM_CDR (form)),
|
||||
SCM_ASSERT (SCM_CONSP (form) && SCM_NULLP (SCM_CDR (form)),
|
||||
form, SCM_ARG1, s_quasiquote);
|
||||
if (0 == depth)
|
||||
return evalcar (form, env);
|
||||
|
|
@ -1120,7 +1108,7 @@ scm_m_atfop (SCM xorig, SCM env SCM_UNUSED)
|
|||
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 (var) + scm_tc3_cons_gloc);
|
||||
SCM_SETCAR (x, var);
|
||||
return x;
|
||||
}
|
||||
|
||||
|
|
@ -1146,7 +1134,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_sym2var (SCM_CAR (x), env, SCM_BOOL_T)) + scm_tc3_cons_gloc);
|
||||
SCM_SETCAR (x, scm_sym2var (SCM_CAR (x), env, SCM_BOOL_T));
|
||||
x = SCM_CDR (x);
|
||||
}
|
||||
return scm_cons (SCM_IM_BIND, SCM_CDR (xorig));
|
||||
|
|
@ -1291,7 +1279,7 @@ unmemocopy (SCM x, SCM env)
|
|||
#ifdef DEBUG_EXTENSIONS
|
||||
SCM p;
|
||||
#endif
|
||||
if (SCM_NCELLP (x) || SCM_NECONSP (x))
|
||||
if (SCM_NCELLP (x) || SCM_NCONSP (x))
|
||||
return x;
|
||||
#ifdef DEBUG_EXTENSIONS
|
||||
p = scm_whash_lookup (scm_source_whash, x);
|
||||
|
|
@ -1459,7 +1447,7 @@ unmemocopy (SCM x, SCM env)
|
|||
env);
|
||||
}
|
||||
loop:
|
||||
while (SCM_CELLP (x = SCM_CDR (x)) && SCM_ECONSP (x))
|
||||
while (SCM_CELLP (x = SCM_CDR (x)) && SCM_CONSP (x))
|
||||
{
|
||||
if (SCM_ISYMP (SCM_CAR (x)))
|
||||
/* skip body markers */
|
||||
|
|
@ -1528,40 +1516,17 @@ SCM
|
|||
scm_eval_args (SCM l, SCM env, SCM proc)
|
||||
{
|
||||
SCM results = SCM_EOL, *lloc = &results, res;
|
||||
while (!SCM_IMP (l))
|
||||
while (SCM_CONSP (l))
|
||||
{
|
||||
#ifdef SCM_CAUTIOUS
|
||||
if (SCM_CONSP (l))
|
||||
{
|
||||
if (SCM_IMP (SCM_CAR (l)))
|
||||
res = SCM_EVALIM (SCM_CAR (l), env);
|
||||
else
|
||||
res = EVALCELLCAR (l, env);
|
||||
}
|
||||
else if (SCM_TYP3 (l) == scm_tc3_cons_gloc)
|
||||
{
|
||||
scm_t_bits vcell =
|
||||
SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell];
|
||||
if (vcell == 0)
|
||||
res = SCM_CAR (l); /* struct planted in code */
|
||||
else
|
||||
res = SCM_GLOC_VAL (SCM_CAR (l));
|
||||
}
|
||||
else
|
||||
goto wrongnumargs;
|
||||
#else
|
||||
res = EVALCAR (l, env);
|
||||
#endif
|
||||
|
||||
*lloc = scm_cons (res, SCM_EOL);
|
||||
lloc = SCM_CDRLOC (*lloc);
|
||||
l = SCM_CDR (l);
|
||||
}
|
||||
#ifdef SCM_CAUTIOUS
|
||||
if (!SCM_NULLP (l))
|
||||
{
|
||||
wrongnumargs:
|
||||
scm_wrong_num_args (proc);
|
||||
}
|
||||
scm_wrong_num_args (proc);
|
||||
#endif
|
||||
return results;
|
||||
}
|
||||
|
|
@ -1758,40 +1723,17 @@ SCM
|
|||
scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
|
||||
{
|
||||
SCM *results = lloc, res;
|
||||
while (!SCM_IMP (l))
|
||||
while (SCM_CONSP (l))
|
||||
{
|
||||
#ifdef SCM_CAUTIOUS
|
||||
if (SCM_CONSP (l))
|
||||
{
|
||||
if (SCM_IMP (SCM_CAR (l)))
|
||||
res = SCM_EVALIM (SCM_CAR (l), env);
|
||||
else
|
||||
res = EVALCELLCAR (l, env);
|
||||
}
|
||||
else if (SCM_TYP3 (l) == scm_tc3_cons_gloc)
|
||||
{
|
||||
scm_t_bits vcell =
|
||||
SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell];
|
||||
if (vcell == 0)
|
||||
res = SCM_CAR (l); /* struct planted in code */
|
||||
else
|
||||
res = SCM_GLOC_VAL (SCM_CAR (l));
|
||||
}
|
||||
else
|
||||
goto wrongnumargs;
|
||||
#else
|
||||
res = EVALCAR (l, env);
|
||||
#endif
|
||||
|
||||
*lloc = scm_cons (res, SCM_EOL);
|
||||
lloc = SCM_CDRLOC (*lloc);
|
||||
l = SCM_CDR (l);
|
||||
}
|
||||
#ifdef SCM_CAUTIOUS
|
||||
if (!SCM_NULLP (l))
|
||||
{
|
||||
wrongnumargs:
|
||||
scm_wrong_num_args (proc);
|
||||
}
|
||||
scm_wrong_num_args (proc);
|
||||
#endif
|
||||
return *results;
|
||||
}
|
||||
|
|
@ -2014,7 +1956,7 @@ dispatch:
|
|||
if (!SCM_CELLP (SCM_CAR (x)))
|
||||
{
|
||||
x = SCM_CAR (x);
|
||||
RETURN (SCM_IMP (x) ? SCM_EVALIM (x, env) : SCM_GLOC_VAL (x))
|
||||
RETURN (SCM_EVALIM (x, env))
|
||||
}
|
||||
|
||||
if (SCM_SYMBOLP (SCM_CAR (x)))
|
||||
|
|
@ -2208,9 +2150,6 @@ dispatch:
|
|||
else
|
||||
t.lloc = scm_lookupcar (x, env, 1);
|
||||
break;
|
||||
case scm_tc3_cons_gloc:
|
||||
t.lloc = SCM_GLOC_VAL_LOC (proc);
|
||||
break;
|
||||
#ifdef MEMOIZE_LOCALS
|
||||
case scm_tc3_imm24:
|
||||
t.lloc = scm_ilookup (proc, env);
|
||||
|
|
@ -2309,8 +2248,8 @@ dispatch:
|
|||
arg2 = *scm_ilookup (proc, env);
|
||||
else if (SCM_NCONSP (proc))
|
||||
{
|
||||
if (SCM_NCELLP (proc))
|
||||
arg2 = SCM_GLOC_VAL (proc);
|
||||
if (SCM_VARIABLEP (proc))
|
||||
arg2 = SCM_VARIABLE_REF (proc);
|
||||
else
|
||||
arg2 = *scm_lookupcar (SCM_CDR (x), env, 1);
|
||||
}
|
||||
|
|
@ -2477,9 +2416,8 @@ dispatch:
|
|||
arg2 = SCM_CDAR (env);
|
||||
while (SCM_NIMP (arg2))
|
||||
{
|
||||
proc = SCM_GLOC_VAL (SCM_CAR (t.arg1));
|
||||
SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t.arg1)) - 1L),
|
||||
SCM_CAR (arg2));
|
||||
proc = SCM_VARIABLE_REF (SCM_CAR (t.arg1));
|
||||
SCM_VARIABLE_SET (SCM_CAR (t.arg1), SCM_CAR (arg2));
|
||||
SCM_SETCAR (arg2, proc);
|
||||
t.arg1 = SCM_CDR (t.arg1);
|
||||
arg2 = SCM_CDR (arg2);
|
||||
|
|
@ -2499,8 +2437,7 @@ dispatch:
|
|||
arg2 = SCM_CDAR (env);
|
||||
while (SCM_NIMP (arg2))
|
||||
{
|
||||
SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t.arg1)) - 1L),
|
||||
SCM_CAR (arg2));
|
||||
SCM_VARIABLE_SET (SCM_CAR (t.arg1), SCM_CAR (arg2));
|
||||
t.arg1 = SCM_CDR (t.arg1);
|
||||
arg2 = SCM_CDR (arg2);
|
||||
}
|
||||
|
|
@ -2557,6 +2494,7 @@ dispatch:
|
|||
case scm_tc7_cclo:
|
||||
case scm_tc7_pws:
|
||||
case scm_tcs_subrs:
|
||||
case scm_tcs_struct:
|
||||
RETURN (x);
|
||||
|
||||
case scm_tc7_variable:
|
||||
|
|
@ -2573,25 +2511,7 @@ dispatch:
|
|||
#endif
|
||||
break;
|
||||
#endif /* ifdef MEMOIZE_LOCALS */
|
||||
|
||||
|
||||
case scm_tcs_cons_gloc: {
|
||||
scm_t_bits vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell];
|
||||
if (vcell == 0) {
|
||||
/* This is a struct implanted in the code, not a gloc. */
|
||||
RETURN (x);
|
||||
} else {
|
||||
proc = SCM_GLOC_VAL (SCM_CAR (x));
|
||||
SCM_ASRTGO (SCM_NIMP (proc), badfun);
|
||||
#ifndef SCM_RECKLESS
|
||||
#ifdef SCM_CAUTIOUS
|
||||
goto checkargs;
|
||||
#endif
|
||||
#endif
|
||||
}
|
||||
break;
|
||||
}
|
||||
|
||||
case scm_tcs_cons_nimcar:
|
||||
orig_sym = SCM_CAR (x);
|
||||
if (SCM_SYMBOLP (orig_sym))
|
||||
|
|
@ -2733,7 +2653,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: /* really structs, not glocs */
|
||||
case scm_tcs_struct:
|
||||
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
|
||||
{
|
||||
x = SCM_ENTITY_PROCEDURE (proc);
|
||||
|
|
@ -2786,14 +2706,6 @@ evapply:
|
|||
else
|
||||
t.arg1 = EVALCELLCAR (x, env);
|
||||
}
|
||||
else if (SCM_TYP3 (x) == scm_tc3_cons_gloc)
|
||||
{
|
||||
scm_t_bits vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell];
|
||||
if (vcell == 0)
|
||||
t.arg1 = SCM_CAR (x); /* struct planted in code */
|
||||
else
|
||||
t.arg1 = SCM_GLOC_VAL (SCM_CAR (x));
|
||||
}
|
||||
else
|
||||
goto wrongnumargs;
|
||||
#else
|
||||
|
|
@ -2888,7 +2800,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: /* really structs, not glocs */
|
||||
case scm_tcs_struct:
|
||||
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
|
||||
{
|
||||
x = SCM_ENTITY_PROCEDURE (proc);
|
||||
|
|
@ -2936,14 +2848,6 @@ evapply:
|
|||
else
|
||||
arg2 = EVALCELLCAR (x, env);
|
||||
}
|
||||
else if (SCM_TYP3 (x) == scm_tc3_cons_gloc)
|
||||
{
|
||||
scm_t_bits vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell];
|
||||
if (vcell == 0)
|
||||
arg2 = SCM_CAR (x); /* struct planted in code */
|
||||
else
|
||||
arg2 = SCM_GLOC_VAL (SCM_CAR (x));
|
||||
}
|
||||
else
|
||||
goto wrongnumargs;
|
||||
#else
|
||||
|
|
@ -2992,7 +2896,7 @@ evapply:
|
|||
proc))),
|
||||
SCM_EOL));
|
||||
#endif
|
||||
case scm_tcs_cons_gloc: /* really structs, not glocs */
|
||||
case scm_tcs_struct:
|
||||
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
|
||||
{
|
||||
x = SCM_ENTITY_PROCEDURE (proc);
|
||||
|
|
@ -3058,7 +2962,7 @@ evapply:
|
|||
}
|
||||
}
|
||||
#ifdef SCM_CAUTIOUS
|
||||
if (SCM_IMP (x) || SCM_NECONSP (x))
|
||||
if (SCM_IMP (x) || SCM_NCONSP (x))
|
||||
goto wrongnumargs;
|
||||
#endif
|
||||
#ifdef DEVAL
|
||||
|
|
@ -3206,7 +3110,7 @@ evapply:
|
|||
x = SCM_CODE (proc);
|
||||
goto nontoplevel_cdrxbegin;
|
||||
#endif /* DEVAL */
|
||||
case scm_tcs_cons_gloc: /* really structs, not glocs */
|
||||
case scm_tcs_struct:
|
||||
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
|
||||
{
|
||||
#ifdef DEVAL
|
||||
|
|
@ -3649,7 +3553,7 @@ tail:
|
|||
debug.vect[0].a.proc = proc;
|
||||
#endif
|
||||
goto tail;
|
||||
case scm_tcs_cons_gloc: /* really structs, not glocs */
|
||||
case scm_tcs_struct:
|
||||
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
|
||||
{
|
||||
#ifdef DEVAL
|
||||
|
|
|
|||
|
|
@ -115,9 +115,7 @@ extern SCM scm_eval_options_interface (SCM setting);
|
|||
? SCM_EVALIM2(x) \
|
||||
: (*scm_ceval_ptr) ((x), (env)))
|
||||
#define SCM_XEVALCAR(x, env) (SCM_NCELLP (SCM_CAR (x)) \
|
||||
? (SCM_IMP (SCM_CAR (x)) \
|
||||
? SCM_EVALIM (SCM_CAR (x), env) \
|
||||
: SCM_GLOC_VAL (SCM_CAR (x))) \
|
||||
? SCM_EVALIM (SCM_CAR (x), env) \
|
||||
: (SCM_SYMBOLP (SCM_CAR (x)) \
|
||||
? *scm_lookupcar (x, env, 1) \
|
||||
: (*scm_ceval_ptr) (SCM_CAR (x), env)))
|
||||
|
|
@ -182,16 +180,6 @@ 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 variable with a
|
||||
* tag of 1. This is called a "gloc".
|
||||
*/
|
||||
|
||||
#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)))
|
||||
|
||||
|
||||
|
||||
extern SCM * scm_ilookup (SCM iloc, SCM env);
|
||||
|
|
|
|||
110
libguile/gc.c
110
libguile/gc.c
|
|
@ -1257,63 +1257,40 @@ gc_mark_loop_first_time:
|
|||
RECURSE (SCM_SETTER (ptr));
|
||||
ptr = SCM_PROCEDURE (ptr);
|
||||
goto_gc_mark_loop;
|
||||
case scm_tcs_cons_gloc:
|
||||
case scm_tcs_struct:
|
||||
{
|
||||
/* 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_t_bits word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_cons_gloc;
|
||||
scm_t_bits * vtable_data = (scm_t_bits *) word0; /* access as struct */
|
||||
if (vtable_data [scm_vtable_index_vcell] != 0)
|
||||
/* XXX - use less explicit code. */
|
||||
scm_t_bits word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_struct;
|
||||
scm_t_bits * vtable_data = (scm_t_bits *) word0;
|
||||
SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]);
|
||||
long len = SCM_SYMBOL_LENGTH (layout);
|
||||
char * fields_desc = SCM_SYMBOL_CHARS (layout);
|
||||
scm_t_bits * struct_data = (scm_t_bits *) SCM_STRUCT_DATA (ptr);
|
||||
|
||||
if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
|
||||
{
|
||||
/* ptr is a gloc */
|
||||
SCM gloc_car = SCM_PACK (word0);
|
||||
RECURSE (gloc_car);
|
||||
ptr = SCM_CDR (ptr);
|
||||
goto gc_mark_loop;
|
||||
}
|
||||
else
|
||||
{
|
||||
/* ptr is a struct */
|
||||
SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]);
|
||||
long len = SCM_SYMBOL_LENGTH (layout);
|
||||
char * fields_desc = SCM_SYMBOL_CHARS (layout);
|
||||
scm_t_bits * struct_data = (scm_t_bits *) SCM_STRUCT_DATA (ptr);
|
||||
|
||||
if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
|
||||
{
|
||||
RECURSE (SCM_PACK (struct_data[scm_struct_i_procedure]));
|
||||
RECURSE (SCM_PACK (struct_data[scm_struct_i_setter]));
|
||||
}
|
||||
if (len)
|
||||
{
|
||||
long x;
|
||||
|
||||
for (x = 0; x < len - 2; x += 2, ++struct_data)
|
||||
if (fields_desc[x] == 'p')
|
||||
RECURSE (SCM_PACK (*struct_data));
|
||||
if (fields_desc[x] == 'p')
|
||||
{
|
||||
if (SCM_LAYOUT_TAILP (fields_desc[x + 1]))
|
||||
for (x = *struct_data++; x; --x, ++struct_data)
|
||||
RECURSE (SCM_PACK (*struct_data));
|
||||
else
|
||||
RECURSE (SCM_PACK (*struct_data));
|
||||
}
|
||||
}
|
||||
/* mark vtable */
|
||||
ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]);
|
||||
goto_gc_mark_loop;
|
||||
RECURSE (SCM_PACK (struct_data[scm_struct_i_procedure]));
|
||||
RECURSE (SCM_PACK (struct_data[scm_struct_i_setter]));
|
||||
}
|
||||
if (len)
|
||||
{
|
||||
long x;
|
||||
|
||||
for (x = 0; x < len - 2; x += 2, ++struct_data)
|
||||
if (fields_desc[x] == 'p')
|
||||
RECURSE (SCM_PACK (*struct_data));
|
||||
if (fields_desc[x] == 'p')
|
||||
{
|
||||
if (SCM_LAYOUT_TAILP (fields_desc[x + 1]))
|
||||
for (x = *struct_data++; x; --x, ++struct_data)
|
||||
RECURSE (SCM_PACK (*struct_data));
|
||||
else
|
||||
RECURSE (SCM_PACK (*struct_data));
|
||||
}
|
||||
}
|
||||
/* mark vtable */
|
||||
ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]);
|
||||
goto_gc_mark_loop;
|
||||
}
|
||||
break;
|
||||
case scm_tcs_closures:
|
||||
|
|
@ -1748,28 +1725,15 @@ scm_gc_sweep ()
|
|||
|
||||
switch SCM_TYP7 (scmptr)
|
||||
{
|
||||
case scm_tcs_cons_gloc:
|
||||
case scm_tcs_struct:
|
||||
{
|
||||
/* Dirk:FIXME:: Again, super ugly code: scmptr may be a
|
||||
* struct or a gloc. See the corresponding comment in
|
||||
* scm_gc_mark.
|
||||
/* Structs need to be freed in a special order.
|
||||
* This is handled by GC C hooks in struct.c.
|
||||
*/
|
||||
scm_t_bits word0 = (SCM_CELL_WORD_0 (scmptr)
|
||||
- scm_tc3_cons_gloc);
|
||||
/* access as struct */
|
||||
scm_t_bits * vtable_data = (scm_t_bits *) word0;
|
||||
if (vtable_data[scm_vtable_index_vcell] == 0)
|
||||
{
|
||||
/* Structs need to be freed in a special order.
|
||||
* This is handled by GC C hooks in struct.c.
|
||||
*/
|
||||
SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_structs_to_free);
|
||||
scm_structs_to_free = scmptr;
|
||||
continue;
|
||||
}
|
||||
/* fall through so that scmptr gets collected */
|
||||
SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_structs_to_free);
|
||||
scm_structs_to_free = scmptr;
|
||||
}
|
||||
break;
|
||||
continue;
|
||||
case scm_tcs_cons_imcar:
|
||||
case scm_tcs_cons_nimcar:
|
||||
case scm_tcs_closures:
|
||||
|
|
|
|||
|
|
@ -1313,7 +1313,7 @@ wrap_init (SCM class, SCM *m, long n)
|
|||
SCM_SET_STRUCT_GC_CHAIN (z, 0);
|
||||
SCM_SET_CELL_WORD_1 (z, m);
|
||||
SCM_SET_CELL_WORD_0 (z, (scm_t_bits) SCM_STRUCT_DATA (class)
|
||||
| scm_tc3_cons_gloc);
|
||||
| scm_tc3_struct);
|
||||
|
||||
return z;
|
||||
}
|
||||
|
|
@ -2594,7 +2594,7 @@ scm_wrap_object (SCM class, void *data)
|
|||
SCM_NEWCELL2 (z);
|
||||
SCM_SETCDR (z, SCM_PACK ((scm_t_bits) data));
|
||||
SCM_SET_STRUCT_GC_CHAIN (z, 0);
|
||||
SCM_SETCAR (z, SCM_UNPACK (SCM_CDR (class)) | scm_tc3_cons_gloc);
|
||||
SCM_SETCAR (z, SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct);
|
||||
return z;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -627,7 +627,7 @@ scm_post_boot_init_modules ()
|
|||
#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);
|
||||
scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_struct);
|
||||
|
||||
resolve_module_var = PERM (scm_c_lookup ("resolve-module"));
|
||||
process_define_module_var = PERM (scm_c_lookup ("process-define-module"));
|
||||
|
|
|
|||
|
|
@ -168,8 +168,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
|
|||
? SCM_INOUT_PCLASS_INDEX | SCM_PTOBNUM (x)
|
||||
: SCM_OUT_PCLASS_INDEX | SCM_PTOBNUM (x))
|
||||
: SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))];
|
||||
case scm_tcs_cons_gloc:
|
||||
/* must be a struct */
|
||||
case scm_tcs_struct:
|
||||
if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID)
|
||||
return SCM_CLASS_OF (x);
|
||||
else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS)
|
||||
|
|
@ -204,7 +203,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
|
|||
return scm_class_unknown;
|
||||
}
|
||||
|
||||
case scm_tc3_cons_gloc:
|
||||
case scm_tc3_struct:
|
||||
case scm_tc3_tc7_1:
|
||||
case scm_tc3_tc7_2:
|
||||
case scm_tc3_closure:
|
||||
|
|
|
|||
|
|
@ -397,7 +397,6 @@ SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display);
|
|||
void
|
||||
scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate)
|
||||
{
|
||||
taloop:
|
||||
switch (SCM_ITAG3 (exp))
|
||||
{
|
||||
case scm_tc3_closure:
|
||||
|
|
@ -451,39 +450,30 @@ taloop:
|
|||
scm_ipruk ("immediate", exp, port);
|
||||
}
|
||||
break;
|
||||
case scm_tc3_cons_gloc:
|
||||
/* gloc */
|
||||
scm_puts ("#@", port);
|
||||
exp = scm_module_reverse_lookup (scm_current_module (),
|
||||
SCM_GLOC_VAR (exp));
|
||||
goto taloop;
|
||||
case scm_tc3_cons:
|
||||
switch (SCM_TYP7 (exp))
|
||||
{
|
||||
case scm_tcs_cons_gloc:
|
||||
|
||||
if (SCM_STRUCT_VTABLE_DATA (exp) [scm_vtable_index_vcell] == 0)
|
||||
{
|
||||
ENTER_NESTED_DATA (pstate, exp, circref);
|
||||
if (SCM_OBJ_CLASS_FLAGS (exp) & SCM_CLASSF_GOOPS)
|
||||
{
|
||||
SCM pwps, print = pstate->writingp ? g_write : g_display;
|
||||
if (!print)
|
||||
goto print_struct;
|
||||
SCM_NEWSMOB (pwps,
|
||||
scm_tc16_port_with_ps,
|
||||
SCM_UNPACK (scm_cons (port, pstate->handle)));
|
||||
scm_call_generic_2 (print, exp, pwps);
|
||||
}
|
||||
else
|
||||
{
|
||||
print_struct:
|
||||
scm_print_struct (exp, port, pstate);
|
||||
}
|
||||
EXIT_NESTED_DATA (pstate);
|
||||
break;
|
||||
}
|
||||
|
||||
case scm_tcs_struct:
|
||||
{
|
||||
ENTER_NESTED_DATA (pstate, exp, circref);
|
||||
if (SCM_OBJ_CLASS_FLAGS (exp) & SCM_CLASSF_GOOPS)
|
||||
{
|
||||
SCM pwps, print = pstate->writingp ? g_write : g_display;
|
||||
if (!print)
|
||||
goto print_struct;
|
||||
SCM_NEWSMOB (pwps,
|
||||
scm_tc16_port_with_ps,
|
||||
SCM_UNPACK (scm_cons (port, pstate->handle)));
|
||||
scm_call_generic_2 (print, exp, pwps);
|
||||
}
|
||||
else
|
||||
{
|
||||
print_struct:
|
||||
scm_print_struct (exp, port, pstate);
|
||||
}
|
||||
EXIT_NESTED_DATA (pstate);
|
||||
}
|
||||
break;
|
||||
case scm_tcs_cons_imcar:
|
||||
case scm_tcs_cons_nimcar:
|
||||
ENTER_NESTED_DATA (pstate, exp, circref);
|
||||
|
|
@ -754,9 +744,7 @@ scm_ipruk (char *hdr, SCM ptr, SCM port)
|
|||
}
|
||||
|
||||
|
||||
/* Print a list. The list may be either a list of ordinary data, or it may be
|
||||
a list that represents code. Lists that represent code may contain gloc
|
||||
cells.
|
||||
/* Print a list.
|
||||
*/
|
||||
void
|
||||
scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate)
|
||||
|
|
@ -772,12 +760,12 @@ scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate)
|
|||
O(depth * N) instead of O(N^2). */
|
||||
hare = SCM_CDR (exp);
|
||||
tortoise = exp;
|
||||
while (SCM_ECONSP (hare))
|
||||
while (SCM_CONSP (hare))
|
||||
{
|
||||
if (SCM_EQ_P (hare, tortoise))
|
||||
goto fancy_printing;
|
||||
hare = SCM_CDR (hare);
|
||||
if (SCM_IMP (hare) || SCM_NECONSP (hare))
|
||||
if (SCM_IMP (hare) || SCM_NCONSP (hare))
|
||||
break;
|
||||
hare = SCM_CDR (hare);
|
||||
tortoise = SCM_CDR (tortoise);
|
||||
|
|
@ -785,7 +773,7 @@ scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate)
|
|||
|
||||
/* No cdr cycles intrinsic to this list */
|
||||
scm_iprin1 (SCM_CAR (exp), port, pstate);
|
||||
for (exp = SCM_CDR (exp); SCM_ECONSP (exp); exp = SCM_CDR (exp))
|
||||
for (exp = SCM_CDR (exp); SCM_CONSP (exp); exp = SCM_CDR (exp))
|
||||
{
|
||||
register long i;
|
||||
|
||||
|
|
@ -814,7 +802,7 @@ fancy_printing:
|
|||
|
||||
scm_iprin1 (SCM_CAR (exp), port, pstate);
|
||||
exp = SCM_CDR (exp); --n;
|
||||
for (; SCM_ECONSP (exp); exp = SCM_CDR (exp))
|
||||
for (; SCM_CONSP (exp); exp = SCM_CDR (exp))
|
||||
{
|
||||
register unsigned long i;
|
||||
|
||||
|
|
|
|||
|
|
@ -137,7 +137,7 @@ scm_i_procedure_arity (SCM proc)
|
|||
if (!SCM_NULLP (proc))
|
||||
r = 1;
|
||||
break;
|
||||
case scm_tcs_cons_gloc:
|
||||
case scm_tcs_struct:
|
||||
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
|
||||
{
|
||||
r = 1;
|
||||
|
|
|
|||
|
|
@ -198,7 +198,7 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
|
|||
if (SCM_NIMP (obj))
|
||||
switch (SCM_TYP7 (obj))
|
||||
{
|
||||
case scm_tcs_cons_gloc:
|
||||
case scm_tcs_struct:
|
||||
if (!SCM_I_OPERATORP (obj))
|
||||
break;
|
||||
case scm_tcs_closures:
|
||||
|
|
|
|||
|
|
@ -218,7 +218,7 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0,
|
|||
if (SCM_MEMOIZEDP (obj))
|
||||
obj = SCM_MEMOIZED_EXP (obj);
|
||||
#ifndef SCM_RECKLESS
|
||||
else if (SCM_NECONSP (obj))
|
||||
else if (SCM_NCONSP (obj))
|
||||
SCM_WRONG_TYPE_ARG (1, obj);
|
||||
#endif
|
||||
p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
|
||||
|
|
|
|||
|
|
@ -402,8 +402,8 @@ scm_free_structs (void *dummy1 SCM_UNUSED,
|
|||
}
|
||||
else
|
||||
{
|
||||
scm_t_bits word0 = SCM_CELL_WORD_0 (obj) - scm_tc3_cons_gloc;
|
||||
/* access as struct */
|
||||
/* XXX - use less explicit code. */
|
||||
scm_t_bits word0 = SCM_CELL_WORD_0 (obj) - scm_tc3_struct;
|
||||
scm_t_bits * vtable_data = (scm_t_bits *) word0;
|
||||
scm_t_bits * data = SCM_STRUCT_DATA (obj);
|
||||
scm_t_struct_free free_struct_data
|
||||
|
|
@ -470,7 +470,8 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
|
|||
SCM_SET_CELL_WORD_1 (handle, data);
|
||||
SCM_SET_STRUCT_GC_CHAIN (handle, 0);
|
||||
scm_struct_init (handle, layout, data, tail_elts, init);
|
||||
SCM_SET_CELL_WORD_0 (handle, (scm_t_bits) SCM_STRUCT_DATA (vtable) + scm_tc3_cons_gloc);
|
||||
SCM_SET_CELL_WORD_0 (handle,
|
||||
(scm_t_bits) SCM_STRUCT_DATA (vtable) + scm_tc3_struct);
|
||||
SCM_ALLOW_INTS;
|
||||
return handle;
|
||||
}
|
||||
|
|
@ -551,7 +552,7 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
|
|||
SCM_SET_STRUCT_GC_CHAIN (handle, 0);
|
||||
data [scm_vtable_index_layout] = SCM_UNPACK (layout);
|
||||
scm_struct_init (handle, layout, data, tail_elts, scm_cons (layout, init));
|
||||
SCM_SET_CELL_WORD_0 (handle, (scm_t_bits) data + scm_tc3_cons_gloc);
|
||||
SCM_SET_CELL_WORD_0 (handle, (scm_t_bits) data + scm_tc3_struct);
|
||||
SCM_ALLOW_INTS;
|
||||
return handle;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -63,7 +63,7 @@
|
|||
#define scm_struct_i_size -1 /* Instance size */
|
||||
#define scm_struct_i_flags -1 /* Upper 12 bits used as flags */
|
||||
#define scm_vtable_index_layout 0 /* A symbol describing the physical arrangement of this type. */
|
||||
#define scm_vtable_index_vcell 1 /* An opaque word, managed by the garbage collector. */
|
||||
#define scm_vtable_index_vcell 1 /* XXX - remove this, it is unused. */
|
||||
#define scm_vtable_index_vtable 2 /* A pointer to the handle for this vtable. */
|
||||
#define scm_vtable_index_printer 3 /* A printer for this struct type. */
|
||||
#define scm_vtable_offset_user 4 /* Where do user fields start? */
|
||||
|
|
@ -75,10 +75,9 @@ typedef size_t (*scm_t_struct_free) (scm_t_bits * vtable, scm_t_bits * data);
|
|||
#define SCM_STRUCTF_LIGHT (1L << 31) /* Light representation
|
||||
(no hidden words) */
|
||||
|
||||
/* Dirk:FIXME:: the SCM_STRUCTP predicate is also fulfilled for glocs */
|
||||
#define SCM_STRUCTP(X) (SCM_NIMP(X) && (SCM_TYP3(X) == scm_tc3_cons_gloc))
|
||||
#define SCM_STRUCTP(X) (SCM_NIMP(X) && (SCM_TYP3(X) == scm_tc3_struct))
|
||||
#define SCM_STRUCT_DATA(X) ((scm_t_bits *) SCM_CELL_WORD_1 (X))
|
||||
#define SCM_STRUCT_VTABLE_DATA(X) ((scm_t_bits *) (SCM_CELL_WORD_0 (X) - scm_tc3_cons_gloc))
|
||||
#define SCM_STRUCT_VTABLE_DATA(X) ((scm_t_bits *) (SCM_CELL_WORD_0 (X) - scm_tc3_struct))
|
||||
|
||||
#define SCM_STRUCT_LAYOUT(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_layout]))
|
||||
#define SCM_SET_STRUCT_LAYOUT(X, v) (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_layout] = SCM_UNPACK (v))
|
||||
|
|
|
|||
109
libguile/tags.h
109
libguile/tags.h
|
|
@ -117,20 +117,24 @@ typedef signed long scm_t_signed_bits;
|
|||
* only (i.e., programmers must keep track of any SCM variables they
|
||||
* create that don't contain ordinary scheme values).
|
||||
*
|
||||
* All immediates and non-immediates must have a 0 in bit 0. Only
|
||||
* non-object values can have a 1 in bit 0. In some cases, bit 0 of a
|
||||
* word in the heap is used for the GC tag so during garbage
|
||||
* collection, that bit might be 1 even in an immediate or
|
||||
* non-immediate value. In other cases, bit 0 of a word in the heap
|
||||
* is used to tag a pointer to a GLOC (VM global variable address) or
|
||||
* the header of a struct. But whenever an SCM variable holds a
|
||||
* normal Scheme value, bit 0 is 0.
|
||||
* All immediates and pointers to cells of non-immediates have a 0 in
|
||||
* bit 0. All non-immediates that are not pairs have a 1 in bit 0 of
|
||||
* the first word of their cell. This is how pairs are distinguished
|
||||
* from other non-immediates; a pair can have a immediate in its car
|
||||
* (thus a 0 in bit 0), or a pointer to the cell of a non-immediate
|
||||
* (again, this pointer has a 0 in bit 0).
|
||||
*
|
||||
* Immediates and non-immediates are distinguished by bits two and four.
|
||||
* Immediate values must have a 1 in at least one of those bits. Does
|
||||
* this (or any other detail of tagging) seem arbitrary? Try changing it!
|
||||
* (Not always impossible but it is fair to say that many details of tags
|
||||
* are mutually dependent). */
|
||||
* Immediates and non-immediates are distinguished by bits 1 and 2.
|
||||
* Immediate values must have a 1 in at least one of those bits.
|
||||
* Consequently, a pointer to a cell of a non-immediate must have
|
||||
* zeros in bits 1 and 2. Together with the requirement from above
|
||||
* that bit 0 must also be zero, this means that pointers to cells of
|
||||
* non-immediates must have their three low bits all zero. This in
|
||||
* turn means that cells must be aligned on a 8 byte boundary, which
|
||||
* is just right for two 32bit numbers (surprise, surprise). Does
|
||||
* this (or any other detail of tagging) seem arbitrary? Try changing
|
||||
* it! (Not always impossible but it is fair to say that many details
|
||||
* of tags are mutually dependent). */
|
||||
|
||||
#define SCM_IMP(x) (6 & SCM_UNPACK (x))
|
||||
#define SCM_NIMP(x) (!SCM_IMP (x))
|
||||
|
|
@ -142,17 +146,17 @@ typedef signed long scm_t_signed_bits;
|
|||
*
|
||||
*
|
||||
* 0 Most objects except...
|
||||
* 1 ...glocs and structs (this tag valid only in a SCM_CAR or
|
||||
* in the header of a struct's data).
|
||||
* 1 ... structs (this tag is valid only in the header
|
||||
* of a struct's data, as with all odd tags).
|
||||
*
|
||||
* 00 heap addresses and many immediates (not integers)
|
||||
* 01 glocs/structs, some tc7_ codes
|
||||
* 01 structs, some tc7_ codes
|
||||
* 10 immediate integers
|
||||
* 11 various tc7_ codes including, tc16_ codes.
|
||||
*
|
||||
*
|
||||
* 000 heap address
|
||||
* 001 glocs/structs
|
||||
* 001 structs
|
||||
* 010 integer
|
||||
* 011 closure
|
||||
* 100 immediates
|
||||
|
|
@ -191,33 +195,35 @@ typedef signed long scm_t_signed_bits;
|
|||
* with the 13 immediates above being some of the most interesting.
|
||||
*
|
||||
* Also noteworthy are the groups of 16 7-bit instructions implied by
|
||||
* some of the 3-bit tags. For example, closure references consist
|
||||
* of an 8-bit aligned address tagged with 011. There are 16 identical 7-bit
|
||||
* instructions, all ending 011, which are invoked by evaluating closures.
|
||||
* some of the 3-bit tags. For example, closure references consist of
|
||||
* an 8-byte aligned address tagged with 011. There are 16 identical
|
||||
* 7-bit instructions, all ending 011, which are invoked by evaluating
|
||||
* closures.
|
||||
*
|
||||
* In other words, if you hand the evaluator a closure, the evaluator
|
||||
* treats the closure as a graph of virtual machine instructions.
|
||||
* A closure is a pair with a pointer to the body of the procedure
|
||||
* in the CDR and a pointer to the environment of the closure in the CAR.
|
||||
* treats the closure as a graph of virtual machine instructions. A
|
||||
* closure is a pair with a pointer to the body of the procedure in
|
||||
* the CDR and a pointer to the environment of the closure in the CAR.
|
||||
* The environment pointer is tagged 011 which implies that the least
|
||||
* significant 7 bits of the environment pointer also happen to be
|
||||
* a virtual machine instruction we could call "SELF" (for self-evaluating
|
||||
* object).
|
||||
* significant 7 bits of the environment pointer also happen to be a
|
||||
* virtual machine instruction we could call "SELF" (for
|
||||
* self-evaluating object).
|
||||
*
|
||||
* A less trivial example are the 16 instructions ending 000. If those
|
||||
* bits tag the CAR of a pair, then evidently the pair is an ordinary
|
||||
* cons pair and should be evaluated as a procedure application. The sixteen,
|
||||
* 7-bit 000 instructions are all "NORMAL-APPLY" (Things get trickier.
|
||||
* For example, if the CAR of a procedure application is a symbol, the NORMAL-APPLY
|
||||
* instruction will, as a side effect, overwrite that CAR with a new instruction
|
||||
* that contains a cached address for the variable named by the symbol.)
|
||||
* A less trivial example are the 16 instructions ending 000. If
|
||||
* those bits tag the CAR of a pair, then evidently the pair is an
|
||||
* ordinary cons pair and should be evaluated as a procedure
|
||||
* application. The sixteen, 7-bit 000 instructions are all
|
||||
* "NORMAL-APPLY" (Things get trickier. For example, if the CAR of a
|
||||
* procedure application is a symbol, the NORMAL-APPLY instruction
|
||||
* will, as a side effect, overwrite that CAR with a new instruction
|
||||
* that contains a cached address for the variable named by the
|
||||
* symbol.)
|
||||
*
|
||||
* Here is a summary of tags in the CAR of a non-immediate:
|
||||
*
|
||||
* HEAP CELL: G=gc_mark; 1 during mark, 0 other times.
|
||||
*
|
||||
* cons ..........SCM car..............0 ...........SCM cdr.............G
|
||||
* gloc ..........SCM vcell..........001 ...........SCM cdr.............G
|
||||
* struct ..........void * type........001 ...........void * data.........G
|
||||
* closure ..........SCM code...........011 ...........SCM env.............G
|
||||
* tc7 ......24.bits of data...Gxxxx1S1 ..........void *data............
|
||||
|
|
@ -284,17 +290,6 @@ typedef signed long scm_t_signed_bits;
|
|||
#define SCM_CONSP(x) (!SCM_IMP (x) && ((1 & SCM_CELL_TYPE (x)) == 0))
|
||||
#define SCM_NCONSP(x) (!SCM_CONSP (x))
|
||||
|
||||
|
||||
/* SCM_ECONSP should be used instead of SCM_CONSP at places where GLOCS
|
||||
* can be expected to occur.
|
||||
*/
|
||||
#define SCM_ECONSP(x) \
|
||||
(!SCM_IMP (x) \
|
||||
&& (SCM_CONSP (x) \
|
||||
|| (SCM_TYP3 (x) == 1 \
|
||||
&& (SCM_STRUCT_VTABLE_DATA (x)[scm_vtable_index_vcell] != 0))))
|
||||
#define SCM_NECONSP(x) (!SCM_ECONSP (x))
|
||||
|
||||
|
||||
|
||||
#define SCM_CELLP(x) (((sizeof (scm_cell) - 1) & SCM_UNPACK (x)) == 0)
|
||||
|
|
@ -303,11 +298,11 @@ typedef signed long scm_t_signed_bits;
|
|||
/* See numbers.h for macros relating to immediate integers.
|
||||
*/
|
||||
|
||||
#define SCM_ITAG3(x) (7 & SCM_UNPACK (x))
|
||||
#define SCM_TYP3(x) (7 & SCM_CELL_TYPE (x))
|
||||
#define scm_tc3_cons 0
|
||||
#define scm_tc3_cons_gloc 1
|
||||
#define scm_tc3_int_1 2
|
||||
#define SCM_ITAG3(x) (7 & SCM_UNPACK (x))
|
||||
#define SCM_TYP3(x) (7 & SCM_CELL_TYPE (x))
|
||||
#define scm_tc3_cons 0
|
||||
#define scm_tc3_struct 1
|
||||
#define scm_tc3_int_1 2
|
||||
#define scm_tc3_closure 3
|
||||
#define scm_tc3_imm24 4
|
||||
#define scm_tc3_tc7_1 5
|
||||
|
|
@ -497,8 +492,10 @@ extern char *scm_isymnames[]; /* defined in print.c */
|
|||
|
||||
|
||||
|
||||
/* Dispatching aids: */
|
||||
/* Dispatching aids:
|
||||
|
||||
When switching on SCM_TYP7 of a SCM value, use these fake case
|
||||
labels to catch types that use fewer than 7 bits for tagging. */
|
||||
|
||||
/* For cons pairs with immediate values in the CAR
|
||||
*/
|
||||
|
|
@ -523,20 +520,22 @@ extern char *scm_isymnames[]; /* defined in print.c */
|
|||
case 64:case 72:case 80:case 88:\
|
||||
case 96:case 104:case 112:case 120
|
||||
|
||||
/* A CONS_GLOC occurs in code. It's CAR is a pointer to the
|
||||
* CDR of a variable. The low order bits of the CAR are 001.
|
||||
* The CDR of the gloc is the code continuation.
|
||||
/* For structs
|
||||
*/
|
||||
#define scm_tcs_cons_gloc 1:case 9:case 17:case 25:\
|
||||
#define scm_tcs_struct 1:case 9:case 17:case 25:\
|
||||
case 33:case 41:case 49:case 57:\
|
||||
case 65:case 73:case 81:case 89:\
|
||||
case 97:case 105:case 113:case 121
|
||||
|
||||
/* For closures
|
||||
*/
|
||||
#define scm_tcs_closures 3:case 11:case 19:case 27:\
|
||||
case 35:case 43:case 51:case 59:\
|
||||
case 67:case 75:case 83:case 91:\
|
||||
case 99:case 107:case 115:case 123
|
||||
|
||||
/* For subrs
|
||||
*/
|
||||
#define scm_tcs_subrs scm_tc7_asubr:case scm_tc7_subr_0:case scm_tc7_subr_1:case scm_tc7_cxr:\
|
||||
case scm_tc7_subr_3:case scm_tc7_subr_2:case scm_tc7_rpsubr:case scm_tc7_subr_1o:\
|
||||
case scm_tc7_subr_2o:case scm_tc7_lsubr_2:case scm_tc7_lsubr
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue