Commit 93511e94 authored by Paul Eggert's avatar Paul Eggert
Browse files

Fix some crashes on self-modifying Elisp code

Prompted by a problem report by Alex in:
http://lists.gnu.org/archive/html/emacs-devel/2017-08/msg00143.html
* src/eval.c (For, Fprogn, Fsetq, FletX, eval_sub):
Compute XCDR (x) near XCAR (x); although this doesn't fix any bugs,
it is likely to run a bit faster with typical hardware caches.
(Fif): Use Fcdr instead of XCDR, to avoid crashing on
self-modifying S-expressions.
(Fsetq, Flet, eval_sub): Count the number of arguments as we go
instead of trusting an Flength prepass, to avoid problems when the
code is self-modifying.
(Fquote, Ffunction, Fdefvar, Fdefconst): Prefer !NILP to CONSP
where either will do.  This is mostly to document the fact that
the value must be a proper list.  It's also a tiny bit faster on
typical machines nowadays.
(Fdefconst, FletX): Prefer XCAR+XCDR to Fcar+Fcdr when either will do.
(eval_sub): Check that the args are a list as opposed to some
other object that has a length. This prevents e.g. (if . "string")
from making Emacs dump core in some cases.
* test/src/eval-tests.el (eval-tests--if-dot-string)
(eval-tests--let-with-circular-defs, eval-tests--mutating-cond):
New tests.
parent 8a406d11
...@@ -354,10 +354,11 @@ usage: (or CONDITIONS...) */) ...@@ -354,10 +354,11 @@ usage: (or CONDITIONS...) */)
while (CONSP (args)) while (CONSP (args))
{ {
val = eval_sub (XCAR (args)); Lisp_Object arg = XCAR (args);
args = XCDR (args);
val = eval_sub (arg);
if (!NILP (val)) if (!NILP (val))
break; break;
args = XCDR (args);
} }
return val; return val;
...@@ -374,10 +375,11 @@ usage: (and CONDITIONS...) */) ...@@ -374,10 +375,11 @@ usage: (and CONDITIONS...) */)
while (CONSP (args)) while (CONSP (args))
{ {
val = eval_sub (XCAR (args)); Lisp_Object arg = XCAR (args);
args = XCDR (args);
val = eval_sub (arg);
if (NILP (val)) if (NILP (val))
break; break;
args = XCDR (args);
} }
return val; return val;
...@@ -397,7 +399,7 @@ usage: (if COND THEN ELSE...) */) ...@@ -397,7 +399,7 @@ usage: (if COND THEN ELSE...) */)
if (!NILP (cond)) if (!NILP (cond))
return eval_sub (Fcar (XCDR (args))); return eval_sub (Fcar (XCDR (args)));
return Fprogn (XCDR (XCDR (args))); return Fprogn (Fcdr (XCDR (args)));
} }
DEFUN ("cond", Fcond, Scond, 0, UNEVALLED, 0, DEFUN ("cond", Fcond, Scond, 0, UNEVALLED, 0,
...@@ -439,8 +441,9 @@ usage: (progn BODY...) */) ...@@ -439,8 +441,9 @@ usage: (progn BODY...) */)
while (CONSP (body)) while (CONSP (body))
{ {
val = eval_sub (XCAR (body)); Lisp_Object form = XCAR (body);
body = XCDR (body); body = XCDR (body);
val = eval_sub (form);
} }
return val; return val;
...@@ -488,35 +491,26 @@ The return value of the `setq' form is the value of the last VAL. ...@@ -488,35 +491,26 @@ The return value of the `setq' form is the value of the last VAL.
usage: (setq [SYM VAL]...) */) usage: (setq [SYM VAL]...) */)
(Lisp_Object args) (Lisp_Object args)
{ {
Lisp_Object val, sym, lex_binding; Lisp_Object val = args, tail = args;
val = args; for (EMACS_INT nargs = 0; CONSP (tail); nargs += 2)
if (CONSP (args))
{ {
Lisp_Object args_left = args; Lisp_Object sym = XCAR (tail), lex_binding;
Lisp_Object numargs = Flength (args); tail = XCDR (tail);
if (!CONSP (tail))
if (XINT (numargs) & 1) xsignal2 (Qwrong_number_of_arguments, Qsetq, make_number (nargs + 1));
xsignal2 (Qwrong_number_of_arguments, Qsetq, numargs); Lisp_Object arg = XCAR (tail);
tail = XCDR (tail);
do val = eval_sub (arg);
{ /* Like for eval_sub, we do not check declared_special here since
val = eval_sub (Fcar (XCDR (args_left))); it's been done when let-binding. */
sym = XCAR (args_left); if (!NILP (Vinternal_interpreter_environment) /* Mere optimization! */
&& SYMBOLP (sym)
/* Like for eval_sub, we do not check declared_special here since && !NILP (lex_binding
it's been done when let-binding. */ = Fassq (sym, Vinternal_interpreter_environment)))
if (!NILP (Vinternal_interpreter_environment) /* Mere optimization! */ XSETCDR (lex_binding, val); /* SYM is lexically bound. */
&& SYMBOLP (sym) else
&& !NILP (lex_binding Fset (sym, val); /* SYM is dynamically bound. */
= Fassq (sym, Vinternal_interpreter_environment)))
XSETCDR (lex_binding, val); /* SYM is lexically bound. */
else
Fset (sym, val); /* SYM is dynamically bound. */
args_left = Fcdr (XCDR (args_left));
}
while (CONSP (args_left));
} }
return val; return val;
...@@ -535,7 +529,7 @@ of unexpected results when a quoted object is modified. ...@@ -535,7 +529,7 @@ of unexpected results when a quoted object is modified.
usage: (quote ARG) */) usage: (quote ARG) */)
(Lisp_Object args) (Lisp_Object args)
{ {
if (CONSP (XCDR (args))) if (!NILP (XCDR (args)))
xsignal2 (Qwrong_number_of_arguments, Qquote, Flength (args)); xsignal2 (Qwrong_number_of_arguments, Qquote, Flength (args));
return XCAR (args); return XCAR (args);
} }
...@@ -549,7 +543,7 @@ usage: (function ARG) */) ...@@ -549,7 +543,7 @@ usage: (function ARG) */)
{ {
Lisp_Object quoted = XCAR (args); Lisp_Object quoted = XCAR (args);
if (CONSP (XCDR (args))) if (!NILP (XCDR (args)))
xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args)); xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args));
if (!NILP (Vinternal_interpreter_environment) if (!NILP (Vinternal_interpreter_environment)
...@@ -734,9 +728,9 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */) ...@@ -734,9 +728,9 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
sym = XCAR (args); sym = XCAR (args);
tail = XCDR (args); tail = XCDR (args);
if (CONSP (tail)) if (!NILP (tail))
{ {
if (CONSP (XCDR (tail)) && CONSP (XCDR (XCDR (tail)))) if (!NILP (XCDR (tail)) && !NILP (XCDR (XCDR (tail))))
error ("Too many arguments"); error ("Too many arguments");
tem = Fdefault_boundp (sym); tem = Fdefault_boundp (sym);
...@@ -803,20 +797,24 @@ usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */) ...@@ -803,20 +797,24 @@ usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
Lisp_Object sym, tem; Lisp_Object sym, tem;
sym = XCAR (args); sym = XCAR (args);
if (CONSP (Fcdr (XCDR (XCDR (args))))) Lisp_Object docstring = Qnil;
error ("Too many arguments"); if (!NILP (XCDR (XCDR (args))))
{
if (!NILP (XCDR (XCDR (XCDR (args)))))
error ("Too many arguments");
docstring = XCAR (XCDR (XCDR (args)));
}
tem = eval_sub (Fcar (XCDR (args))); tem = eval_sub (XCAR (XCDR (args)));
if (!NILP (Vpurify_flag)) if (!NILP (Vpurify_flag))
tem = Fpurecopy (tem); tem = Fpurecopy (tem);
Fset_default (sym, tem); Fset_default (sym, tem);
XSYMBOL (sym)->declared_special = 1; XSYMBOL (sym)->declared_special = 1;
tem = Fcar (XCDR (XCDR (args))); if (!NILP (docstring))
if (!NILP (tem))
{ {
if (!NILP (Vpurify_flag)) if (!NILP (Vpurify_flag))
tem = Fpurecopy (tem); docstring = Fpurecopy (docstring);
Fput (sym, Qvariable_documentation, tem); Fput (sym, Qvariable_documentation, docstring);
} }
Fput (sym, Qrisky_local_variable, Qt); Fput (sym, Qrisky_local_variable, Qt);
LOADHIST_ATTACH (sym); LOADHIST_ATTACH (sym);
...@@ -844,27 +842,29 @@ Each VALUEFORM can refer to the symbols already bound by this VARLIST. ...@@ -844,27 +842,29 @@ Each VALUEFORM can refer to the symbols already bound by this VARLIST.
usage: (let* VARLIST BODY...) */) usage: (let* VARLIST BODY...) */)
(Lisp_Object args) (Lisp_Object args)
{ {
Lisp_Object varlist, var, val, elt, lexenv; Lisp_Object var, val, elt, lexenv;
ptrdiff_t count = SPECPDL_INDEX (); ptrdiff_t count = SPECPDL_INDEX ();
lexenv = Vinternal_interpreter_environment; lexenv = Vinternal_interpreter_environment;
for (varlist = XCAR (args); CONSP (varlist); varlist = XCDR (varlist)) Lisp_Object varlist = XCAR (args);
while (CONSP (varlist))
{ {
maybe_quit (); maybe_quit ();
elt = XCAR (varlist); elt = XCAR (varlist);
varlist = XCDR (varlist);
if (SYMBOLP (elt)) if (SYMBOLP (elt))
{ {
var = elt; var = elt;
val = Qnil; val = Qnil;
} }
else if (! NILP (Fcdr (Fcdr (elt))))
signal_error ("`let' bindings can have only one value-form", elt);
else else
{ {
var = Fcar (elt); var = Fcar (elt);
val = eval_sub (Fcar (Fcdr (elt))); if (! NILP (Fcdr (XCDR (elt))))
signal_error ("`let' bindings can have only one value-form", elt);
val = eval_sub (Fcar (XCDR (elt)));
} }
if (!NILP (lexenv) && SYMBOLP (var) if (!NILP (lexenv) && SYMBOLP (var)
...@@ -911,33 +911,37 @@ usage: (let VARLIST BODY...) */) ...@@ -911,33 +911,37 @@ usage: (let VARLIST BODY...) */)
CHECK_LIST (varlist); CHECK_LIST (varlist);
/* Make space to hold the values to give the bound variables. */ /* Make space to hold the values to give the bound variables. */
elt = Flength (varlist); EMACS_INT varlist_len = XFASTINT (Flength (varlist));
SAFE_ALLOCA_LISP (temps, XFASTINT (elt)); SAFE_ALLOCA_LISP (temps, varlist_len);
ptrdiff_t nvars = varlist_len;
/* Compute the values and store them in `temps'. */ /* Compute the values and store them in `temps'. */
for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist)) for (argnum = 0; argnum < nvars && CONSP (varlist); argnum++)
{ {
maybe_quit (); maybe_quit ();
elt = XCAR (varlist); elt = XCAR (varlist);
varlist = XCDR (varlist);
if (SYMBOLP (elt)) if (SYMBOLP (elt))
temps [argnum++] = Qnil; temps[argnum] = Qnil;
else if (! NILP (Fcdr (Fcdr (elt)))) else if (! NILP (Fcdr (Fcdr (elt))))
signal_error ("`let' bindings can have only one value-form", elt); signal_error ("`let' bindings can have only one value-form", elt);
else else
temps [argnum++] = eval_sub (Fcar (Fcdr (elt))); temps[argnum] = eval_sub (Fcar (Fcdr (elt)));
} }
nvars = argnum;
lexenv = Vinternal_interpreter_environment; lexenv = Vinternal_interpreter_environment;
varlist = XCAR (args); varlist = XCAR (args);
for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist)) for (argnum = 0; argnum < nvars && CONSP (varlist); argnum++)
{ {
Lisp_Object var; Lisp_Object var;
elt = XCAR (varlist); elt = XCAR (varlist);
varlist = XCDR (varlist);
var = SYMBOLP (elt) ? elt : Fcar (elt); var = SYMBOLP (elt) ? elt : Fcar (elt);
tem = temps[argnum++]; tem = temps[argnum];
if (!NILP (lexenv) && SYMBOLP (var) if (!NILP (lexenv) && SYMBOLP (var)
&& !XSYMBOL (var)->declared_special && !XSYMBOL (var)->declared_special
...@@ -2135,6 +2139,7 @@ eval_sub (Lisp_Object form) ...@@ -2135,6 +2139,7 @@ eval_sub (Lisp_Object form)
original_fun = XCAR (form); original_fun = XCAR (form);
original_args = XCDR (form); original_args = XCDR (form);
CHECK_LIST (original_args);
/* This also protects them from gc. */ /* This also protects them from gc. */
count = record_in_backtrace (original_fun, &original_args, UNEVALLED); count = record_in_backtrace (original_fun, &original_args, UNEVALLED);
...@@ -2176,15 +2181,16 @@ eval_sub (Lisp_Object form) ...@@ -2176,15 +2181,16 @@ eval_sub (Lisp_Object form)
SAFE_ALLOCA_LISP (vals, XINT (numargs)); SAFE_ALLOCA_LISP (vals, XINT (numargs));
while (!NILP (args_left)) while (CONSP (args_left) && argnum < XINT (numargs))
{ {
vals[argnum++] = eval_sub (Fcar (args_left)); Lisp_Object arg = XCAR (args_left);
args_left = Fcdr (args_left); args_left = XCDR (args_left);
vals[argnum++] = eval_sub (arg);
} }
set_backtrace_args (specpdl + count, vals, XINT (numargs)); set_backtrace_args (specpdl + count, vals, argnum);
val = (XSUBR (fun)->function.aMANY) (XINT (numargs), vals); val = XSUBR (fun)->function.aMANY (argnum, vals);
check_cons_list (); check_cons_list ();
lisp_eval_depth--; lisp_eval_depth--;
......
...@@ -59,4 +59,24 @@ Bug#24912 and Bug#24913." ...@@ -59,4 +59,24 @@ Bug#24912 and Bug#24913."
(should-error (,form ,arg) :type 'wrong-type-argument)) (should-error (,form ,arg) :type 'wrong-type-argument))
t))) t)))
(ert-deftest eval-tests--if-dot-string ()
"Check that Emacs rejects (if . \"string\")."
(should-error (eval '(if . "abc")) :type 'wrong-type-argument)
(let ((if-tail (list '(setcdr if-tail "abc") t)))
(should-error (eval (cons 'if if-tail))))
(let ((if-tail (list '(progn (setcdr if-tail "abc") nil) t)))
(should-error (eval (cons 'if if-tail)))))
(ert-deftest eval-tests--let-with-circular-defs ()
"Check that Emacs reports an error for (let VARS ...) when VARS is circular."
(let ((vars (list 'v)))
(setcdr vars vars)
(dolist (let-sym '(let let*))
(should-error (eval (list let-sym vars))))))
(ert-deftest eval-tests--mutating-cond ()
"Check that Emacs doesn't crash on a cond clause that mutates during eval."
(let ((clauses (list '((progn (setcdr clauses "ouch") nil)))))
(should-error (eval (cons 'cond clauses)))))
;;; eval-tests.el ends here ;;; eval-tests.el ends here
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment