summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--THANKS1
-rw-r--r--libguile/ChangeLog19
-rw-r--r--libguile/eval.c139
-rw-r--r--libguile/eval.h4
4 files changed, 137 insertions, 26 deletions
diff --git a/THANKS b/THANKS
index b01e1bf42..f68493edf 100644
--- a/THANKS
+++ b/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
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));