diff options
-rw-r--r-- | THANKS | 1 | ||||
-rw-r--r-- | libguile/ChangeLog | 19 | ||||
-rw-r--r-- | libguile/eval.c | 139 | ||||
-rw-r--r-- | libguile/eval.h | 4 |
4 files changed, 137 insertions, 26 deletions
@@ -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 diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 2e260e298..95c46780b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -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. diff --git a/libguile/eval.c b/libguile/eval.c index 403f54cc3..e571e7889 100644 --- a/libguile/eval.c +++ b/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); diff --git a/libguile/eval.h b/libguile/eval.h index 9f218c07e..094afa319 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -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)); |