summaryrefslogtreecommitdiff
path: root/libguile/eval.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/eval.c')
-rw-r--r--libguile/eval.c176
1 files changed, 40 insertions, 136 deletions
diff --git a/libguile/eval.c b/libguile/eval.c
index 1978b2632..ff681d86d 100644
--- a/libguile/eval.c
+++ b/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