Slightly extending commit 16b0520a9

Slightly extending commit 16b0520a9

[Alex]

Commit 16b0520a9 changed various Fcar/Fcdr calls into XCAR/XCDR, but I
believe I see two more instances where this change can also be applied.
In both cases, XCDR is already being applied on XCDR (args), so XCAR
should also be fine.

diff --git a/src/eval.c b/src/eval.c
index e5900382de..d132959f0c 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -396,7 +396,7 @@ usage: (if COND THEN ELSE...)  */)
   cond = eval_sub (XCAR (args));
 
   if (!NILP (cond))
-    return eval_sub (Fcar (XCDR (args)));
+    return eval_sub (XCAR (XCDR (args)));
   return Fprogn (XCDR (XCDR (args)));
 }
 
@@ -806,7 +806,7 @@ usage: (defconst SYMBOL INITVALUE [DOCSTRING])  */)
   if (CONSP (Fcdr (XCDR (XCDR (args)))))
     error ("Too many arguments");
 
-  tem = eval_sub (Fcar (XCDR (args)));
+  tem = eval_sub (XCAR (XCDR (args)));
   if (!NILP (Vpurify_flag))
     tem = Fpurecopy (tem);
   Fset_default (sym, tem);

Re: Slightly extending commit 16b0520a9

[Stefan Monnier]

>    cond = eval_sub (XCAR (args));
>
>    if (!NILP (cond))
> -    return eval_sub (Fcar (XCDR (args)));
> +    return eval_sub (XCAR (XCDR (args)));

I don't see anything in the preceding code that guarantees that `XCDR (args)`
holds a cons, so I think XCAR here is unsafe.

> @@ -806,7 +806,7 @@ usage: (defconst SYMBOL INITVALUE [DOCSTRING])  */)
>    if (CONSP (Fcdr (XCDR (XCDR (args)))))
>      error ("Too many arguments");
> 
> -  tem = eval_sub (Fcar (XCDR (args)));
> +  tem = eval_sub (XCAR (XCDR (args)));

This one looks right, yes,


        Stefan

Re: Slightly extending commit 16b0520a9

[Alex]

Stefan Monnier <monnier@iro.umontreal.ca> writes:

>>    cond = eval_sub (XCAR (args));
>>
>>    if (!NILP (cond))
>> -    return eval_sub (Fcar (XCDR (args)));
>> +    return eval_sub (XCAR (XCDR (args)));
>
> I don't see anything in the preceding code that guarantees that `XCDR (args)`
> holds a cons, so I think XCAR here is unsafe.

The following line includes "XCDR (XCDR (args))", and the value of cond
should not affect the type of XCDR (args). If XCDR is allowed in this
case, then IIUC XCAR should be allowed as well.

I believe the reason why we can assume that XCDR (args) is a cons cell
is that `if' requires at least 2 (unevalled) arguments, so args must be
a list of at least length 2.

Re: Slightly extending commit 16b0520a9

[Stefan Monnier]

>>> cond = eval_sub (XCAR (args));
>>> if (!NILP (cond))
>>> -    return eval_sub (Fcar (XCDR (args)));
>>> +    return eval_sub (XCAR (XCDR (args)));
>> I don't see anything in the preceding code that guarantees that `XCDR (args)`
>> holds a cons, so I think XCAR here is unsafe.
> The following line includes "XCDR (XCDR (args))",

Indeed, that looks like a bug.

> I believe the reason why we can assume that XCDR (args) is a cons cell
> is that `if' requires at least 2 (unevalled) arguments, so args must be
> a list of at least length 2.

Try (eval '(if nil . "hello"))

[ ... trying it himself ... ]

Hmm... it turns out that indeed it seems that XCDR and XCAR here are
safe because before calling those functions, eval_sub happens to call
Flength on the args, and that triggers an error if the form is not
a proper list, so `XCDR (args)` will indeed be a cons once we get
to Fif.

Arguably Fif could be called from elsewhere than eval_sub, and arguably
eval_sub's implementation could be changed in such a way that it doesn't
catch this error, so the safety of using XCDR is debatable.

The important thing to remember, tho, is that Fif should not be
performance sensitive: code whose performance matters should be
byte-compiled in which case it doesn't call Fif (as is the case for all
other special forms).


        Stefan

Re: Slightly extending commit 16b0520a9

[Paul Eggert]

[-- Attachment #1: Type: text/plain, Size: 1609 bytes --]

Stefan Monnier wrote:
> it seems that XCDR and XCAR here are
> safe because before calling those functions, eval_sub happens to call
> Flength on the args, and that triggers an error if the form is not
> a proper list, so `XCDR (args)` will indeed be a cons once we get
> to Fif.

That's true only if the S-expression does not mutate as it is being evaluated. 
If the S-expression modifies itself after Flength and before XCDR, Emacs can 
crash. So Alex's first patch is the opposite of what it should be: instead of 
changing the Fcar to an XCAR, we should change an XCDR to an Fcdr in the next 
line. I looked for nearby instances of this problem, and fixed them by 
installing the attached patch. This should address both problems that Alex 
mentioned.

> Arguably Fif could be called from elsewhere than eval_sub, and arguably
> eval_sub's implementation could be changed in such a way that it doesn't
> catch this error, so the safety of using XCDR is debatable.

Even before the attached patch was installed, several UNEVALLED functions 
assumed that their arguments were proper lists. So, when writing the 
abovementioned patch, I found it simpler to make this assumption everywhere. The 
argument lists might become improper if they are mutated, so UNEVALLED functions 
that can invoke arbitrary lisp code still must check the lists as they go, though.

> Fif should not be performance sensitive

Yes, in this part of eval.c using XCDR instead of Fcdr is helpful mostly as a 
hint to the reader that the object is a cons; it's not a significant performance 
improvement.

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Fix-some-crashes-on-self-modifying-Elisp-code.patch --]
[-- Type: text/x-patch; name="0001-Fix-some-crashes-on-self-modifying-Elisp-code.patch", Size: 11387 bytes --]

From d4278e1dbb023a230b8b0dbc212f0f3fa4391a72 Mon Sep 17 00:00:00 2001
From: Paul Eggert <eggert@cs.ucla.edu>
Date: Sun, 6 Aug 2017 16:57:08 -0700
Subject: [PATCH] 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.
---
 src/eval.c             | 128 ++++++++++++++++++++++++++-----------------------
 test/src/eval-tests.el |  20 ++++++++
 2 files changed, 87 insertions(+), 61 deletions(-)

diff --git a/src/eval.c b/src/eval.c
index e590038..fe2708b 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -354,10 +354,11 @@ usage: (or CONDITIONS...)  */)
 
   while (CONSP (args))
     {
-      val = eval_sub (XCAR (args));
+      Lisp_Object arg = XCAR (args);
+      args = XCDR (args);
+      val = eval_sub (arg);
       if (!NILP (val))
 	break;
-      args = XCDR (args);
     }
 
   return val;
@@ -374,10 +375,11 @@ usage: (and CONDITIONS...)  */)
 
   while (CONSP (args))
     {
-      val = eval_sub (XCAR (args));
+      Lisp_Object arg = XCAR (args);
+      args = XCDR (args);
+      val = eval_sub (arg);
       if (NILP (val))
 	break;
-      args = XCDR (args);
     }
 
   return val;
@@ -397,7 +399,7 @@ usage: (if COND THEN ELSE...)  */)
 
   if (!NILP (cond))
     return eval_sub (Fcar (XCDR (args)));
-  return Fprogn (XCDR (XCDR (args)));
+  return Fprogn (Fcdr (XCDR (args)));
 }
 
 DEFUN ("cond", Fcond, Scond, 0, UNEVALLED, 0,
@@ -439,8 +441,9 @@ usage: (progn BODY...)  */)
 
   while (CONSP (body))
     {
-      val = eval_sub (XCAR (body));
+      Lisp_Object form = XCAR (body);
       body = XCDR (body);
+      val = eval_sub (form);
     }
 
   return val;
@@ -488,35 +491,26 @@ The return value of the `setq' form is the value of the last VAL.
 usage: (setq [SYM VAL]...)  */)
   (Lisp_Object args)
 {
-  Lisp_Object val, sym, lex_binding;
+  Lisp_Object val = args, tail = args;
 
-  val = args;
-  if (CONSP (args))
+  for (EMACS_INT nargs = 0; CONSP (tail); nargs += 2)
     {
-      Lisp_Object args_left = args;
-      Lisp_Object numargs = Flength (args);
-
-      if (XINT (numargs) & 1)
-        xsignal2 (Qwrong_number_of_arguments, Qsetq, numargs);
-
-      do
-	{
-	  val = eval_sub (Fcar (XCDR (args_left)));
-	  sym = XCAR (args_left);
-
-	  /* Like for eval_sub, we do not check declared_special here since
-	     it's been done when let-binding.  */
-	  if (!NILP (Vinternal_interpreter_environment) /* Mere optimization!  */
-	      && SYMBOLP (sym)
-	      && !NILP (lex_binding
-			= 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));
+      Lisp_Object sym = XCAR (tail), lex_binding;
+      tail = XCDR (tail);
+      if (!CONSP (tail))
+	xsignal2 (Qwrong_number_of_arguments, Qsetq, make_number (nargs + 1));
+      Lisp_Object arg = XCAR (tail);
+      tail = XCDR (tail);
+      val = eval_sub (arg);
+      /* Like for eval_sub, we do not check declared_special here since
+	 it's been done when let-binding.  */
+      if (!NILP (Vinternal_interpreter_environment) /* Mere optimization!  */
+	  && SYMBOLP (sym)
+	  && !NILP (lex_binding
+		    = Fassq (sym, Vinternal_interpreter_environment)))
+	XSETCDR (lex_binding, val); /* SYM is lexically bound.  */
+      else
+	Fset (sym, val);	/* SYM is dynamically bound.  */
     }
 
   return val;
@@ -535,7 +529,7 @@ of unexpected results when a quoted object is modified.
 usage: (quote ARG)  */)
   (Lisp_Object args)
 {
-  if (CONSP (XCDR (args)))
+  if (!NILP (XCDR (args)))
     xsignal2 (Qwrong_number_of_arguments, Qquote, Flength (args));
   return XCAR (args);
 }
@@ -549,7 +543,7 @@ usage: (function ARG)  */)
 {
   Lisp_Object quoted = XCAR (args);
 
-  if (CONSP (XCDR (args)))
+  if (!NILP (XCDR (args)))
     xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args));
 
   if (!NILP (Vinternal_interpreter_environment)
@@ -734,9 +728,9 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING)  */)
   sym = XCAR (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");
 
       tem = Fdefault_boundp (sym);
@@ -803,20 +797,24 @@ usage: (defconst SYMBOL INITVALUE [DOCSTRING])  */)
   Lisp_Object sym, tem;
 
   sym = XCAR (args);
-  if (CONSP (Fcdr (XCDR (XCDR (args)))))
-    error ("Too many arguments");
+  Lisp_Object docstring = Qnil;
+  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))
     tem = Fpurecopy (tem);
   Fset_default (sym, tem);
   XSYMBOL (sym)->declared_special = 1;
-  tem = Fcar (XCDR (XCDR (args)));
-  if (!NILP (tem))
+  if (!NILP (docstring))
     {
       if (!NILP (Vpurify_flag))
-	tem = Fpurecopy (tem);
-      Fput (sym, Qvariable_documentation, tem);
+	docstring = Fpurecopy (docstring);
+      Fput (sym, Qvariable_documentation, docstring);
     }
   Fput (sym, Qrisky_local_variable, Qt);
   LOADHIST_ATTACH (sym);
@@ -844,27 +842,29 @@ Each VALUEFORM can refer to the symbols already bound by this VARLIST.
 usage: (let* VARLIST BODY...)  */)
   (Lisp_Object args)
 {
-  Lisp_Object varlist, var, val, elt, lexenv;
+  Lisp_Object var, val, elt, lexenv;
   ptrdiff_t count = SPECPDL_INDEX ();
 
   lexenv = Vinternal_interpreter_environment;
 
-  for (varlist = XCAR (args); CONSP (varlist); varlist = XCDR (varlist))
+  Lisp_Object varlist = XCAR (args);
+  while (CONSP (varlist))
     {
       maybe_quit ();
 
       elt = XCAR (varlist);
+      varlist = XCDR (varlist);
       if (SYMBOLP (elt))
 	{
 	  var = elt;
 	  val = Qnil;
 	}
-      else if (! NILP (Fcdr (Fcdr (elt))))
-	signal_error ("`let' bindings can have only one value-form", elt);
       else
 	{
 	  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)
@@ -911,33 +911,37 @@ usage: (let VARLIST BODY...)  */)
   CHECK_LIST (varlist);
 
   /* Make space to hold the values to give the bound variables.  */
-  elt = Flength (varlist);
-  SAFE_ALLOCA_LISP (temps, XFASTINT (elt));
+  EMACS_INT varlist_len = XFASTINT (Flength (varlist));
+  SAFE_ALLOCA_LISP (temps, varlist_len);
+  ptrdiff_t nvars = varlist_len;
 
   /* 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 ();
       elt = XCAR (varlist);
+      varlist = XCDR (varlist);
       if (SYMBOLP (elt))
-	temps [argnum++] = Qnil;
+	temps[argnum] = Qnil;
       else if (! NILP (Fcdr (Fcdr (elt))))
 	signal_error ("`let' bindings can have only one value-form", elt);
       else
-	temps [argnum++] = eval_sub (Fcar (Fcdr (elt)));
+	temps[argnum] = eval_sub (Fcar (Fcdr (elt)));
     }
+  nvars = argnum;
 
   lexenv = Vinternal_interpreter_environment;
 
   varlist = XCAR (args);
-  for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist))
+  for (argnum = 0; argnum < nvars && CONSP (varlist); argnum++)
     {
       Lisp_Object var;
 
       elt = XCAR (varlist);
+      varlist = XCDR (varlist);
       var = SYMBOLP (elt) ? elt : Fcar (elt);
-      tem = temps[argnum++];
+      tem = temps[argnum];
 
       if (!NILP (lexenv) && SYMBOLP (var)
 	  && !XSYMBOL (var)->declared_special
@@ -2135,6 +2139,7 @@ eval_sub (Lisp_Object form)
 
   original_fun = XCAR (form);
   original_args = XCDR (form);
+  CHECK_LIST (original_args);
 
   /* This also protects them from gc.  */
   count = record_in_backtrace (original_fun, &original_args, UNEVALLED);
@@ -2176,15 +2181,16 @@ eval_sub (Lisp_Object form)
 
 	  SAFE_ALLOCA_LISP (vals, XINT (numargs));
 
-	  while (!NILP (args_left))
+	  while (CONSP (args_left) && argnum < XINT (numargs))
 	    {
-	      vals[argnum++] = eval_sub (Fcar (args_left));
-	      args_left = Fcdr (args_left);
+	      Lisp_Object arg = XCAR (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 ();
 	  lisp_eval_depth--;
diff --git a/test/src/eval-tests.el b/test/src/eval-tests.el
index 03f4087..b98de0a 100644
--- a/test/src/eval-tests.el
+++ b/test/src/eval-tests.el
@@ -59,4 +59,24 @@ byte-compile-debug
         (should-error (,form ,arg) :type 'wrong-type-argument))
      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
-- 
2.7.4