* eval.c (SCM_CEVAL): Do more thorough argument checking. This
change makes the evaluator safer at the cost of evaluation speed. It handles the case when the user has added a non-immediate improper end of the application form, e.g., `(+ 0 . x)'. (Earlier only cases like `(+ 0 . 0)' were handled.) I've tried to minimize the extra cost as much as possible. The new code is enclosed in #ifdef CAUTIOUS regions. NOTE: This also fixes the problem with structs planted directly in the code (e.g. by a macro). This no longer causes segmentation fault. (Thanks to Eric Hanchrow.) * eval.c, eval.h (scm_eval_args, scm_deval_args): Take one extra arg `proc' in order to be able to throw errors; New argument checking code.
This commit is contained in:
Mikael Djurfeldt
parent
c153090d62
commit
680ed4a802
4 changed files with 137 additions and 26 deletions
1
THANKS
1
THANKS
|
|
@ -14,6 +14,7 @@ Bug reports and fixes from:
|
|||
Marcus Daniels
|
||||
Fred Fish
|
||||
Jesse N. Glick
|
||||
Eric Hanchrow
|
||||
Karl M. Hegbloom
|
||||
Dirk Herrmann
|
||||
Bill Janssen
|
||||
|
|
|
|||
|
|
@ -1,3 +1,22 @@
|
|||
1998-05-02 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
|
||||
|
||||
* eval.c (SCM_CEVAL): Do more thorough argument checking. This
|
||||
change makes the evaluator safer at the cost of evaluation speed.
|
||||
It handles the case when the user has added a non-immediate
|
||||
improper end of the application form, e.g., `(+ 0 . x)'.
|
||||
(Earlier only cases like `(+ 0 . 0)' were handled.) I've tried to
|
||||
minimize the extra cost as much as possible. The new code is
|
||||
enclosed in #ifdef CAUTIOUS regions. NOTE: This also fixes the
|
||||
problem with structs planted directly in the code (e.g. by a
|
||||
macro). This no longer causes segmentation fault. (Thanks to
|
||||
Eric Hanchrow.)
|
||||
|
||||
* eval.c, eval.h (scm_eval_args, scm_deval_args): Take one extra
|
||||
arg `proc' in order to be able to throw errors; New argument
|
||||
checking code.
|
||||
|
||||
* Removed extra #include "debug.h"
|
||||
|
||||
1998-04-25 Mikael Djurfeldt <mdj@kenneth>
|
||||
|
||||
* scmsigs.c: Declare usleep as returning void on some systems.
|
||||
|
|
|
|||
139
libguile/eval.c
139
libguile/eval.c
|
|
@ -86,11 +86,6 @@ char *alloca ();
|
|||
#include "procprop.h"
|
||||
#include "hashtab.h"
|
||||
#include "hash.h"
|
||||
|
||||
#ifdef DEBUG_EXTENSIONS
|
||||
#include "debug.h"
|
||||
#endif /* DEBUG_EXTENSIONS */
|
||||
|
||||
#include "srcprop.h"
|
||||
#include "stackchk.h"
|
||||
#include "objects.h"
|
||||
|
|
@ -1283,18 +1278,46 @@ long scm_tc16_macro;
|
|||
|
||||
|
||||
SCM
|
||||
scm_eval_args (l, env)
|
||||
scm_eval_args (l, env, proc)
|
||||
SCM l;
|
||||
SCM env;
|
||||
SCM proc;
|
||||
{
|
||||
SCM res = SCM_EOL, *lloc = &res;
|
||||
SCM results = SCM_EOL, *lloc = &results, res;
|
||||
while (SCM_NIMP (l))
|
||||
{
|
||||
*lloc = scm_cons (EVALCAR (l, env), SCM_EOL);
|
||||
#ifdef CAUTIOUS
|
||||
if (SCM_IMP (l))
|
||||
goto wrongnumargs;
|
||||
else if (SCM_CONSP (l))
|
||||
{
|
||||
if (SCM_IMP (SCM_CAR (l)))
|
||||
res = EVALIM (SCM_CAR (l), env);
|
||||
else
|
||||
res = EVALCELLCAR (l, env);
|
||||
}
|
||||
else if (SCM_TYP3 (l) == 1)
|
||||
{
|
||||
if ((res = SCM_GLOC_VAL (SCM_CAR (l))) == 0)
|
||||
res = SCM_CAR (l); /* struct planted in code */
|
||||
}
|
||||
else
|
||||
goto wrongnumargs;
|
||||
#else
|
||||
res = EVALCAR (l, env);
|
||||
#endif
|
||||
*lloc = scm_cons (res, SCM_EOL);
|
||||
lloc = SCM_CDRLOC (*lloc);
|
||||
l = SCM_CDR (l);
|
||||
}
|
||||
return res;
|
||||
#ifdef CAUTIOUS
|
||||
if (SCM_NNULLP (l))
|
||||
{
|
||||
wrongnumargs:
|
||||
scm_wrong_num_args (proc);
|
||||
}
|
||||
#endif
|
||||
return results;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1489,17 +1512,44 @@ scm_evaluator_traps (setting)
|
|||
}
|
||||
|
||||
SCM
|
||||
scm_deval_args (l, env, lloc)
|
||||
SCM l, env, *lloc;
|
||||
scm_deval_args (l, env, proc, lloc)
|
||||
SCM l, env, proc, *lloc;
|
||||
{
|
||||
SCM *res = lloc;
|
||||
SCM *results = lloc, res;
|
||||
while (SCM_NIMP (l))
|
||||
{
|
||||
*lloc = scm_cons (EVALCAR (l, env), SCM_EOL);
|
||||
#ifdef CAUTIOUS
|
||||
if (SCM_IMP (l))
|
||||
goto wrongnumargs;
|
||||
else if (SCM_CONSP (l))
|
||||
{
|
||||
if (SCM_IMP (SCM_CAR (l)))
|
||||
res = EVALIM (SCM_CAR (l), env);
|
||||
else
|
||||
res = EVALCELLCAR (l, env);
|
||||
}
|
||||
else if (SCM_TYP3 (l) == 1)
|
||||
{
|
||||
if ((res = SCM_GLOC_VAL (SCM_CAR (l))) == 0)
|
||||
res = SCM_CAR (l); /* struct planted in code */
|
||||
}
|
||||
else
|
||||
goto wrongnumargs;
|
||||
#else
|
||||
res = EVALCAR (l, env);
|
||||
#endif
|
||||
*lloc = scm_cons (res, SCM_EOL);
|
||||
lloc = SCM_CDRLOC (*lloc);
|
||||
l = SCM_CDR (l);
|
||||
}
|
||||
return *res;
|
||||
#ifdef CAUTIOUS
|
||||
if (SCM_NNULLP (l))
|
||||
{
|
||||
wrongnumargs:
|
||||
scm_wrong_num_args (proc);
|
||||
}
|
||||
#endif
|
||||
return *results;
|
||||
}
|
||||
|
||||
#endif /* !DEVAL */
|
||||
|
|
@ -2204,8 +2254,23 @@ evapply:
|
|||
#ifdef CAUTIOUS
|
||||
if (SCM_IMP (x))
|
||||
goto wrongnumargs;
|
||||
#endif
|
||||
else if (SCM_CONSP (x))
|
||||
{
|
||||
if (SCM_IMP (SCM_CAR (x)))
|
||||
t.arg1 = EVALIM (SCM_CAR (x), env);
|
||||
else
|
||||
t.arg1 = EVALCELLCAR (x, env);
|
||||
}
|
||||
else if (SCM_TYP3 (x) == 1)
|
||||
{
|
||||
if ((t.arg1 = SCM_GLOC_VAL (SCM_CAR (x))) == 0)
|
||||
t.arg1 = SCM_CAR (x); /* struct planted in code */
|
||||
}
|
||||
else
|
||||
goto wrongnumargs;
|
||||
#else
|
||||
t.arg1 = EVALCAR (x, env);
|
||||
#endif
|
||||
#ifdef DEVAL
|
||||
debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
|
||||
#endif
|
||||
|
|
@ -2325,9 +2390,24 @@ evapply:
|
|||
#ifdef CAUTIOUS
|
||||
if (SCM_IMP (x))
|
||||
goto wrongnumargs;
|
||||
else if (SCM_CONSP (x))
|
||||
{
|
||||
if (SCM_IMP (SCM_CAR (x)))
|
||||
arg2 = EVALIM (SCM_CAR (x), env);
|
||||
else
|
||||
arg2 = EVALCELLCAR (x, env);
|
||||
}
|
||||
else if (SCM_TYP3 (x) == 1)
|
||||
{
|
||||
if ((arg2 = SCM_GLOC_VAL (SCM_CAR (x))) == 0)
|
||||
arg2 = SCM_CAR (x); /* struct planted in code */
|
||||
}
|
||||
else
|
||||
goto wrongnumargs;
|
||||
#else
|
||||
arg2 = EVALCAR (x, env);
|
||||
#endif
|
||||
{ /* have two or more arguments */
|
||||
arg2 = EVALCAR (x, env);
|
||||
#ifdef DEVAL
|
||||
debug.info->a.args = scm_cons2 (t.arg1, arg2, SCM_EOL);
|
||||
#endif
|
||||
|
|
@ -2362,7 +2442,7 @@ evapply:
|
|||
#else
|
||||
RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), proc,
|
||||
scm_cons2 (t.arg1, arg2,
|
||||
scm_cons (scm_eval_args (x, env),
|
||||
scm_cons (scm_eval_args (x, env, proc),
|
||||
SCM_EOL))));
|
||||
#endif
|
||||
/* case scm_tc7_cclo:
|
||||
|
|
@ -2423,9 +2503,14 @@ evapply:
|
|||
goto cdrxbegin;
|
||||
}
|
||||
}
|
||||
#ifdef CAUTIOUS
|
||||
if (SCM_IMP (x) || SCM_NECONSP (x))
|
||||
goto wrongnumargs;
|
||||
#endif
|
||||
#ifdef DEVAL
|
||||
debug.info->a.args = scm_cons2 (t.arg1, arg2,
|
||||
scm_deval_args (x, env, SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
|
||||
scm_deval_args (x, env, proc,
|
||||
SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
|
||||
#endif
|
||||
ENTER_APPLY;
|
||||
switch (SCM_TYP7 (proc))
|
||||
|
|
@ -2514,12 +2599,16 @@ evapply:
|
|||
RETURN (SCM_BOOL_T)
|
||||
#else /* BUILTIN_RPASUBR */
|
||||
RETURN (SCM_APPLY (proc, t.arg1,
|
||||
scm_acons (arg2, scm_eval_args (x, env), SCM_EOL)));
|
||||
scm_acons (arg2,
|
||||
scm_eval_args (x, env, proc),
|
||||
SCM_EOL)));
|
||||
#endif /* BUILTIN_RPASUBR */
|
||||
case scm_tc7_lsubr_2:
|
||||
RETURN (SCM_SUBRF (proc) (t.arg1, arg2, scm_eval_args (x, env)));
|
||||
RETURN (SCM_SUBRF (proc) (t.arg1, arg2, scm_eval_args (x, env, proc)));
|
||||
case scm_tc7_lsubr:
|
||||
RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, scm_eval_args (x, env))));
|
||||
RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1,
|
||||
arg2,
|
||||
scm_eval_args (x, env, proc))));
|
||||
#ifdef CCLO
|
||||
case scm_tc7_cclo:
|
||||
goto cclon;
|
||||
|
|
@ -2529,7 +2618,9 @@ evapply:
|
|||
SCM_SET_ARGSREADY (debug);
|
||||
#endif
|
||||
env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
|
||||
scm_cons2 (t.arg1, arg2, scm_eval_args (x, env)),
|
||||
scm_cons2 (t.arg1,
|
||||
arg2,
|
||||
scm_eval_args (x, env, proc)),
|
||||
SCM_ENV (proc));
|
||||
x = SCM_CODE (proc);
|
||||
goto cdrxbegin;
|
||||
|
|
@ -2549,7 +2640,7 @@ evapply:
|
|||
#else
|
||||
RETURN (SCM_SUBRF (p) (proc, t.arg1,
|
||||
scm_cons (arg2,
|
||||
scm_eval_args (x, env))))
|
||||
scm_eval_args (x, env, proc))))
|
||||
#endif
|
||||
else if (SCM_CLOSUREP (p))
|
||||
{
|
||||
|
|
@ -2566,7 +2657,7 @@ evapply:
|
|||
env = EXTEND_ENV (SCM_CAR (SCM_CODE (p)),
|
||||
scm_cons2 (proc, t.arg1,
|
||||
scm_cons (arg2,
|
||||
scm_eval_args (x, env))),
|
||||
scm_eval_args (x, env, proc))),
|
||||
SCM_ENV (p));
|
||||
#endif
|
||||
x = SCM_CODE (p);
|
||||
|
|
|
|||
|
|
@ -134,8 +134,8 @@ extern SCM * scm_lookupcar SCM_P ((SCM vloc, SCM genv));
|
|||
extern SCM scm_unmemocar SCM_P ((SCM form, SCM env));
|
||||
extern SCM scm_unmemocopy SCM_P ((SCM form, SCM env));
|
||||
extern SCM scm_eval_car SCM_P ((SCM pair, SCM env));
|
||||
extern SCM scm_eval_args SCM_P ((SCM i, SCM env));
|
||||
extern SCM scm_deval_args SCM_P ((SCM l, SCM env, SCM *lloc));
|
||||
extern SCM scm_eval_args SCM_P ((SCM i, SCM env, SCM proc));
|
||||
extern SCM scm_deval_args SCM_P ((SCM l, SCM env, SCM proc, SCM *lloc));
|
||||
extern SCM scm_m_quote SCM_P ((SCM xorig, SCM env));
|
||||
extern SCM scm_m_begin SCM_P ((SCM xorig, SCM env));
|
||||
extern SCM scm_m_if SCM_P ((SCM xorig, SCM env));
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue