summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMikael Djurfeldt <djurfeldt@nada.kth.se>1996-10-20 03:30:16 +0000
committerMikael Djurfeldt <djurfeldt@nada.kth.se>1996-10-20 03:30:16 +0000
commita23afe534a0de89f47f67d2a0cc9ecae449915f3 (patch)
treea85cbe1bb127e308f51b5d2b5a245381d2ad7427
parente6d34cb65d1c0e0d605cc3363d9831f8446d9a04 (diff)
downloadguile-a23afe534a0de89f47f67d2a0cc9ecae449915f3.tar.gz
* pairs.h, eval.c, eval.h, feature.c, gc.c, list.c, load.c,
ramap.c, symbols.c: Added new selectors SCM_CARLOC and SCM_CDRLOC for obtaining the address of a car or cdr field. Motivation: &SCM_CXR make assumptions about the internal structure of the SCM_CXR selectors. * eval.h, eval.c: Added new selector SCM_GLOC_VAL_LOC. Motivation: see SCM_CXRLOC. * pairs.h, eval.c, gc.c, init.c, ioext.c, ports.c, ports.h, srcprop.h, tags.h, throw.c, unif.c: Added new selectors SCM_SETAND_CAR, SCM_SETAND_CDR, SCM_SETOR_CAR and SCM_SETOR_CDR. Motivation: Safer use. Some other macros are defined in terms of these operations. If these are defined using the SCM_SETCXR (<e1>, SCM_CXR (<e1>) <op> <e2>) pattern a complex <e1> will lead to inefficiency and an <e1> with side-effects could potentially break. Also, these particular operations are heavily utilized in the garbage collector. In unoptimized code there will be a measurable speedup. * alist.c, arbiters.c, continuations.c, debug.c, debug.h, eval.c, eval.h, feature.c, filesys.c, fports.c, gc.c, gsubr.c, init.c, ioext.c, kw.c, list.c, load.c, mallocs.c, numbers.c, numbers.h, pairs.c, pairs.h, ports.c, ports.h, posix.c, procprop.c, procs.c, procs.h, ramap.c, read.c, root.c, srcprop.c, srcprop.h, strports.c, symbols.c, tags.h, throw.c, unif.c, variable.c, vports.c: Cleaned up use of pairs: Don't make any special assumptions about the internal structure of selectors and mutators: SCM_CXR (<e1>) = <e2> --> SCM_SETCXR (<e1>, <e2>), SCM_CXR (<e1>) &= <e2> --> SCM_SETAND_CXR (<e1>, <e2>) etc. (Among other things, this change makes it easier to build Guile with certain compilers which have problems with casted lvalues.)
-rw-r--r--libguile/eval.c142
1 files changed, 76 insertions, 66 deletions
diff --git a/libguile/eval.c b/libguile/eval.c
index a260a863a..6bb13543d 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -158,8 +158,8 @@ scm_ilookup (iloc, env)
for (ir = SCM_IDIST (iloc); 0 != ir; --ir)
er = SCM_CDR (er);
if (SCM_ICDRP (iloc))
- return &SCM_CDR (er);
- return &SCM_CAR (SCM_CDR (er));
+ return SCM_CDRLOC (er);
+ return SCM_CARLOC (SCM_CDR (er));
}
#endif
@@ -178,20 +178,20 @@ scm_lookupcar (vloc, genv)
{
if (SCM_BOOL_T == scm_procedure_p (SCM_CAR (env)))
break;
- al = &SCM_CAR (env);
+ al = SCM_CARLOC (env);
for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl))
{
if (SCM_NCONSP (fl))
if (fl == var)
{
#ifdef MEMOIZE_LOCALS
- SCM_CAR (vloc) = iloc + SCM_ICDR;
+ SCM_SETCAR (vloc, iloc + SCM_ICDR);
#endif
- return &SCM_CDR (*al);
+ return SCM_CDRLOC (*al);
}
else
break;
- al = &SCM_CDR (*al);
+ al = SCM_CDRLOC (*al);
if (SCM_CAR (fl) == var)
{
#ifdef MEMOIZE_LOCALS
@@ -202,9 +202,9 @@ scm_lookupcar (vloc, genv)
goto errout;
}
#endif
- SCM_CAR (vloc) = iloc;
+ SCM_SETCAR (vloc, iloc);
#endif
- return &SCM_CAR (*al);
+ return SCM_CARLOC (*al);
}
#ifdef MEMOIZE_LOCALS
iloc += SCM_IDINC;
@@ -244,11 +244,11 @@ scm_lookupcar (vloc, genv)
SCM_BOOL_F);
}
#endif
- SCM_CAR (vloc) = var + 1;
+ SCM_SETCAR (vloc, var + 1);
/* Except wait...what if the var is not a vcell,
* but syntax or something....
*/
- return &SCM_CDR (var);
+ return SCM_CDRLOC (var);
}
#define unmemocar scm_unmemocar
@@ -267,7 +267,7 @@ scm_unmemocar (form, env)
return form;
c = SCM_CAR (form);
if (1 == (c & 7))
- SCM_CAR (form) = SCM_CAR (c - 1);
+ SCM_SETCAR (form, SCM_CAR (c - 1));
#ifdef MEMOIZE_LOCALS
#ifdef DEBUG_EXTENSIONS
else if (SCM_ILOCP (c))
@@ -277,7 +277,7 @@ scm_unmemocar (form, env)
env = SCM_CAR (SCM_CAR (env));
for (ir = SCM_IDIST (c); ir != 0; --ir)
env = SCM_CDR (env);
- SCM_CAR (form) = SCM_ICDRP (c) ? env : SCM_CAR (env);
+ SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env));
}
#endif
#endif
@@ -492,7 +492,7 @@ scm_m_cond (xorig, env)
if (scm_i_else == SCM_CAR (arg1))
{
ASSYNT (SCM_NULLP (SCM_CDR (x)) && len >= 2, xorig, "bad ELSE clause", "cond");
- SCM_CAR (arg1) = SCM_BOOL_T;
+ SCM_SETCAR (arg1, SCM_BOOL_T);
}
if (len >= 2 && scm_i_arrow == SCM_CAR (SCM_CDR (arg1)))
ASSYNT (3 == len && SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1)))),
@@ -538,7 +538,7 @@ scm_m_lambda (xorig, env)
(proc)
badforms:scm_wta (xorig, s_formals, "lambda");
memlambda:
- bodycheck (xorig, &SCM_CDR (x), "lambda");
+ bodycheck (xorig, SCM_CDRLOC (x), "lambda");
return scm_cons (SCM_IM_LAMBDA, SCM_CDR (xorig));
}
@@ -560,11 +560,11 @@ scm_m_letstar (xorig, env)
ASSYNT (2 == scm_ilength (arg1), xorig, s_bindings, "let*");
ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), xorig, s_variable, "let*");
*varloc = scm_cons2 (SCM_CAR (arg1), SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
- varloc = &SCM_CDR (SCM_CDR (*varloc));
+ varloc = SCM_CDRLOC (SCM_CDR (*varloc));
proc = SCM_CDR (proc);
}
x = scm_cons (vars, SCM_CDR (x));
- bodycheck (xorig, &SCM_CDR (x), "let*");
+ bodycheck (xorig, SCM_CDRLOC (x), "let*");
return scm_cons (SCM_IM_LETSTAR, x);
}
@@ -607,17 +607,17 @@ scm_m_do (xorig, env)
vars = scm_cons (SCM_CAR (arg1), vars); /* variable */
arg1 = SCM_CDR (arg1);
*initloc = scm_cons (SCM_CAR (arg1), SCM_EOL); /* init */
- initloc = &SCM_CDR (*initloc);
+ initloc = SCM_CDRLOC (*initloc);
arg1 = SCM_CDR (arg1);
*steploc = scm_cons (SCM_IMP (arg1) ? SCM_CAR (vars) : SCM_CAR (arg1), SCM_EOL); /* step */
- steploc = &SCM_CDR (*steploc);
+ steploc = SCM_CDRLOC (*steploc);
proc = SCM_CDR (proc);
}
x = SCM_CDR (x);
ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, xorig, s_test, "do");
x = scm_cons2 (SCM_CAR (x), SCM_CDR (x), steps);
x = scm_cons2 (vars, inits, x);
- bodycheck (xorig, &SCM_CAR (SCM_CDR (SCM_CDR (x))), "do");
+ bodycheck (xorig, SCM_CARLOC (SCM_CDR (SCM_CDR (x))), "do");
return scm_cons (SCM_IM_DO, x);
}
@@ -755,7 +755,7 @@ scm_m_define (x, env)
if (5 <= scm_verbose && SCM_UNDEFINED != SCM_CDR (arg1))
scm_warn ("redefining ", SCM_CHARS (proc));
#endif
- SCM_CDR (arg1) = x;
+ SCM_SETCDR (arg1, x);
#ifdef SICP
return scm_cons2 (scm_i_quote, SCM_CAR (arg1), SCM_EOL);
#else
@@ -788,7 +788,7 @@ scm_m_undefine (x, env)
if (5 <= scm_verbose && SCM_UNDEFINED != SCM_CDR (arg1))
scm_warn ("redefining ", SCM_CHARS (x));
#endif
- SCM_CDR (arg1) = SCM_UNDEFINED;
+ SCM_SETCDR (arg1, SCM_UNDEFINED);
#ifdef SICP
return SCM_CAR (arg1);
#else
@@ -822,12 +822,12 @@ scm_m_letrec (xorig, env)
ASRTSYNTAX (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), s_variable);
vars = scm_cons (SCM_CAR (arg1), vars);
*initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
- initloc = &SCM_CDR (*initloc);
+ initloc = SCM_CDRLOC (*initloc);
}
while SCM_NIMP
(proc = SCM_CDR (proc));
cdrx = scm_cons2 (vars, inits, SCM_CDR (x));
- bodycheck (xorig, &SCM_CDR (SCM_CDR (cdrx)), what);
+ bodycheck (xorig, SCM_CDRLOC (SCM_CDR (cdrx)), what);
return scm_cons (SCM_IM_LETREC, cdrx);
}
@@ -864,9 +864,9 @@ scm_m_let (xorig, env)
ASSYNT (2 == scm_ilength (arg1), xorig, s_bindings, "let");
ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), xorig, s_variable, "let");
*varloc = scm_cons (SCM_CAR (arg1), SCM_EOL);
- varloc = &SCM_CDR (*varloc);
+ varloc = SCM_CDRLOC (*varloc);
*initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
- initloc = &SCM_CDR (*initloc);
+ initloc = SCM_CDRLOC (*initloc);
proc = SCM_CDR (proc);
}
return
@@ -976,13 +976,15 @@ unmemocopy (x, env)
s = SCM_CDR (s);
}
while SCM_NIMP (v);
- SCM_CDR (ls) = z = scm_cons (z, SCM_UNSPECIFIED);
+ z = scm_cons (z, SCM_UNSPECIFIED);
+ SCM_SETCDR (ls, z);
if (SCM_CAR (ls) == scm_i_do)
{
x = SCM_CDR (x);
- z = (SCM_CDR (z) = scm_cons (unmemocopy (SCM_CAR (x), env),
+ SCM_SETCDR (z, scm_cons (unmemocopy (SCM_CAR (x), env),
SCM_UNSPECIFIED));
- x = (SCM) (&SCM_CAR (SCM_CDR (x)) - 1);
+ z = SCM_CDR (z);
+ x = (SCM) (SCM_CARLOC (SCM_CDR (x)) - 1);
}
break;
}
@@ -1011,15 +1013,16 @@ unmemocopy (x, env)
}
do
{
- z = (SCM_CDR (z) = scm_acons (SCM_CAR (b),
- unmemocar (
+ SCM_SETCDR (z, scm_acons (SCM_CAR (b),
+ unmemocar (
scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b)), env), SCM_EOL), env),
- SCM_UNSPECIFIED));
+ SCM_UNSPECIFIED));
+ z = SCM_CDR (z);
env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
b = SCM_CDR (SCM_CDR (b));
}
while SCM_NIMP (b);
- SCM_CDR (z) = SCM_EOL;
+ SCM_SETCDR (z, SCM_EOL);
letstar:
ls = scm_cons (scm_i_letstar, z = scm_cons (y, SCM_UNSPECIFIED));
break;
@@ -1046,7 +1049,7 @@ unmemocopy (x, env)
ls = scm_cons (scm_i_define,
z = scm_cons (n = SCM_CAR (x), SCM_UNSPECIFIED));
if (SCM_NNULLP (env))
- SCM_CAR (SCM_CAR (env)) = scm_cons (n, SCM_CAR (SCM_CAR (env)));
+ SCM_SETCAR (SCM_CAR (env), scm_cons (n, SCM_CAR (SCM_CAR (env))));
break;
}
case (127 & SCM_MAKISYM (0)):
@@ -1071,10 +1074,13 @@ unmemocopy (x, env)
}
loop:
while (SCM_CELLP (x = SCM_CDR (x)) && SCM_ECONSP (x))
- z = (SCM_CDR (z) = unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env),
- SCM_UNSPECIFIED),
- env));
- SCM_CDR (z) = x;
+ {
+ SCM_SETCDR (z, unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env),
+ SCM_UNSPECIFIED),
+ env));
+ z = SCM_CDR (z);
+ }
+ SCM_SETCDR (z, x);
#ifdef DEBUG_EXTENSIONS
if (SCM_NFALSEP (p))
scm_whash_insert (scm_source_whash, ls, p);
@@ -1131,7 +1137,7 @@ scm_eval_args (l, env)
while (SCM_NIMP (l))
{
*lloc = scm_cons (EVALCAR (l, env), SCM_EOL);
- lloc = &SCM_CDR (*lloc);
+ lloc = SCM_CDRLOC (*lloc);
l = SCM_CDR (l);
}
return res;
@@ -1258,7 +1264,7 @@ scm_deval_args (l, env, lloc)
while (SCM_NIMP (l))
{
*lloc = scm_cons (EVALCAR (l, env), SCM_EOL);
- lloc = &SCM_CDR (*lloc);
+ lloc = SCM_CDRLOC (*lloc);
l = SCM_CDR (l);
}
return *res;
@@ -1575,7 +1581,7 @@ dispatch:
t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
}
while (SCM_NIMP (proc = SCM_CDR (proc)));
- SCM_CDR (SCM_CAR (env)) = t.arg1;
+ SCM_SETCDR (SCM_CAR (env), t.arg1);
goto cdrxnoap;
@@ -1629,7 +1635,7 @@ dispatch:
t.lloc = scm_lookupcar (x, env);
break;
case 1:
- t.lloc = &SCM_GLOC_VAL (proc);
+ t.lloc = SCM_GLOC_VAL_LOC (proc);
break;
#ifdef MEMOIZE_LOCALS
case 4:
@@ -1657,8 +1663,8 @@ dispatch:
#endif
env = SCM_CAR (env);
SCM_DEFER_INTS;
- SCM_CAR (env) = scm_cons (proc, SCM_CAR (env));
- SCM_CDR (env) = scm_cons (x, SCM_CDR (env));
+ SCM_SETCAR (env, scm_cons (proc, SCM_CAR (env)));
+ SCM_SETCDR (env, scm_cons (x, SCM_CDR (env)));
SCM_ALLOW_INTS;
RETURN (SCM_UNSPECIFIED);
@@ -1813,8 +1819,8 @@ dispatch:
}
#endif
SCM_DEFER_INTS;
- SCM_CAR (x) = SCM_CAR (t.arg1);
- SCM_CDR (x) = SCM_CDR (t.arg1);
+ SCM_SETCAR (x, SCM_CAR (t.arg1));
+ SCM_SETCDR (x, SCM_CDR (t.arg1));
SCM_ALLOW_INTS;
goto dispatch;
}
@@ -1824,8 +1830,8 @@ dispatch:
scm_source_properties (x));
#endif
SCM_DEFER_INTS;
- SCM_CAR (x) = SCM_CAR (t.arg1);
- SCM_CDR (x) = SCM_CDR (t.arg1);
+ SCM_SETCAR (x, SCM_CAR (t.arg1));
+ SCM_SETCDR (x, SCM_CDR (t.arg1));
SCM_ALLOW_INTS;
goto loopnoap;
case 1:
@@ -2080,7 +2086,7 @@ evapply:
}
#ifdef DEVAL
debug.info->a.args = scm_cons2 (t.arg1, arg2,
- scm_deval_args (x, env, &SCM_CDR (SCM_CDR (debug.info->a.args))));
+ scm_deval_args (x, env, SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
#endif
ENTER_APPLY;
switch (SCM_TYP7 (proc))
@@ -2245,7 +2251,7 @@ scm_nconc2last (lst)
SCM_ASSERT (scm_ilength (lst) > 0, lst, SCM_ARG1, s_nconc2last);
lloc = &lst;
while (SCM_NNULLP (SCM_CDR (*lloc)))
- lloc = &SCM_CDR (*lloc);
+ lloc = SCM_CDRLOC (*lloc);
SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, s_nconc2last);
*lloc = SCM_CAR (*lloc);
return lst;
@@ -2516,7 +2522,7 @@ scm_map (proc, arg1, args)
{
SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG2, s_map);
*pres = scm_cons (scm_apply (proc, SCM_CAR (arg1), scm_listofnull), SCM_EOL);
- pres = &SCM_CDR (*pres);
+ pres = SCM_CDRLOC (*pres);
arg1 = SCM_CDR (arg1);
}
return res;
@@ -2538,7 +2544,7 @@ scm_map (proc, arg1, args)
ve[i] = SCM_CDR (ve[i]);
}
*pres = scm_cons (scm_apply (proc, arg1, SCM_EOL), SCM_EOL);
- pres = &SCM_CDR (*pres);
+ pres = SCM_CDRLOC (*pres);
}
}
@@ -2596,7 +2602,7 @@ scm_closure (code, env)
register SCM z;
SCM_NEWCELL (z);
SCM_SETCODE (z, code);
- SCM_ENV (z) = env;
+ SCM_SETENV (z, env);
return z;
}
@@ -2609,8 +2615,8 @@ scm_makprom (code)
{
register SCM z;
SCM_NEWCELL (z);
- SCM_CDR (z) = code;
- SCM_CAR (z) = scm_tc16_promise;
+ SCM_SETCDR (z, code);
+ SCM_SETCAR (z, scm_tc16_promise);
return z;
}
@@ -2642,8 +2648,8 @@ scm_makacro (code)
{
register SCM z;
SCM_NEWCELL (z);
- SCM_CDR (z) = code;
- SCM_CAR (z) = scm_tc16_macro;
+ SCM_SETCDR (z, code);
+ SCM_SETCAR (z, scm_tc16_macro);
return z;
}
@@ -2656,8 +2662,8 @@ scm_makmacro (code)
{
register SCM z;
SCM_NEWCELL (z);
- SCM_CDR (z) = code;
- SCM_CAR (z) = scm_tc16_macro | (1L << 16);
+ SCM_SETCDR (z, code);
+ SCM_SETCAR (z, scm_tc16_macro | (1L << 16));
return z;
}
@@ -2670,8 +2676,8 @@ scm_makmmacro (code)
{
register SCM z;
SCM_NEWCELL (z);
- SCM_CDR (z) = code;
- SCM_CAR (z) = scm_tc16_macro | (2L << 16);
+ SCM_SETCDR (z, code);
+ SCM_SETCAR (z, scm_tc16_macro | (2L << 16));
return z;
}
@@ -2713,8 +2719,8 @@ scm_force (x)
if (!((1L << 16) & SCM_CAR (x)))
{
SCM_DEFER_INTS;
- SCM_CDR (x) = ans;
- SCM_CAR (x) |= (1L << 16);
+ SCM_SETCDR (x, ans);
+ SCM_SETOR_CAR (x, (1L << 16));
SCM_ALLOW_INTS;
}
}
@@ -2754,8 +2760,12 @@ scm_copy_tree (obj)
/* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */
ans = tl = scm_cons (scm_copy_tree (SCM_CAR (obj)), SCM_UNSPECIFIED);
while (SCM_NIMP (obj = SCM_CDR (obj)) && SCM_CONSP (obj))
- tl = (SCM_CDR (tl) = scm_cons (scm_copy_tree (SCM_CAR (obj)), SCM_UNSPECIFIED));
- SCM_CDR (tl) = obj;
+ {
+ SCM_SETCDR (tl, scm_cons (scm_copy_tree (SCM_CAR (obj)),
+ SCM_UNSPECIFIED));
+ tl = SCM_CDR (tl);
+ }
+ SCM_SETCDR (tl, obj);
return ans;
}
@@ -2864,8 +2874,8 @@ scm_make_synt (name, macroizer, fcn)
tmp = 0;
SCM_NEWCELL (z);
SCM_SUBRF (z) = fcn;
- SCM_CAR (z) = tmp + scm_tc7_subr_2;
- SCM_CDR (symcell) = macroizer (z);
+ SCM_SETCAR (z, tmp + scm_tc7_subr_2);
+ SCM_SETCDR (symcell, macroizer (z));
return SCM_CAR (symcell);
}