Subject: bug#75648: Minor safety improvements to fns.c/eval.c

From: Pip Cet <[email-masked]>
Date: Sat, 18 Jan 2025 14:20:39 +0000

"Pip Cet via \"Bug reports for GNU Emacs, the Swiss army knife of text editors\"" <[email-masked]> writes:

> 1. Give such tests a :crash tag
> 2. Introduce a should-not-crash macro which succeeds if the form it
> evaluates returns in any way, whether by error or not.
> 3. Modify ert.el to print when a :crash test is about to start running.
> This allows us to identify the crashing test.
> 4. Deviate from the current logical test order and put crash tests last.
> It's conceivable that if a once-fixed crash reoccurs, the reason is a
> simple bug that may show up in regular tests, too.  If two tests fail
> and one of them crashes the test run, it's better for the first failure
> to have been reported first.
>
> I'll send a patch once this has a bug number.

Patch 1 adds :crash tests to ert.el.
Patch 2 adds new tests which crash if the bug is present.
Patch 3 fixes the actual bug.

Remarks:
* should-not-crash needs to be written carefully to avoid byte compiler
warnings and, in the general case, ignore errors.
* printing the test name before the crash makes a lot of sense to me,
and it's easier to do in ert-run-tests-batch rather than in
should-not-crash itself.
* plist_put wasn't buggy, but I applied analogous changes to keep it
synchronized  with Fplist_put.

commit a4bf048d1f36680d37ffbd4c54c67ea13840117c
Author: Pip Cet <[email-masked]>
Date:   Sat Jan 18 12:26:36 2025 +0000

    Handle tests known to cause crashes
    
    * lisp/emacs-lisp/ert.el (should-not-crash): New macro.
    (ert-run-tests-batch): When running a test with a :crash tag, print
    a message first.

diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index f25ba8a529c..cd25fe6a108 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -457,6 +457,14 @@ should-error
                        (list
                         :fail-reason "did not signal an error")))))))))
 
+(cl-defmacro should-not-crash (form)
+  "Evaluate FORM and ignore its value.
+
+If Emacs doesn't crash, count it as a success.
+
+Returns nil."
+  `(should-not (and (ignore-errors ,form) nil)))
+
 (cl-defmacro ert--skip-when (form)
   "Evaluate FORM.  If it returns t, skip the current test.
 Errors during evaluation are caught and handled like t."
@@ -1439,7 +1447,20 @@ ert-run-tests-batch
               (message "%s" ""))
             (when (getenv "EMACS_TEST_JUNIT_REPORT")
               (ert-write-junit-test-report stats)))))
-       (test-started)
+       (test-started
+        ;; for tests which might crash, the last line of output should
+        ;; indicate which test we attempted to run.
+        (cl-destructuring-bind (stats test ) event-args
+          (and (not ert-quiet)
+               (memq :crash (ert-test-tags test))
+               (let* ((max (prin1-to-string (length (ert--stats-tests stats))))
+                      (format-string (concat "%9s  %"
+                                             (prin1-to-string (length max))
+                                             "s/" max "  %S")))
+                 (message format-string
+                          "started"
+                          (1+ (ert--stats-test-pos stats test))
+                          (ert-test-name test))))))
        (test-ended
         (cl-destructuring-bind (stats test result) event-args
           (unless (ert-test-result-expected-p test result)

commit f891757a7b71980fc81afff0e818911ad6e1f344
Author: Pip Cet <[email-masked]>
Date:   Sat Jan 18 12:27:58 2025 +0000

    Add :crash tests for bug#75648
    
    * test/src/fns-tests.el (test-self-modifying-plist-get):
    (test-self-modifying-plist-put): New tests.

diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index eebc92bfd41..edb919badcd 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -1817,4 +1817,16 @@ fns-value<-bool-vector
                     ;; Undo the flip.
                     (aset b i val)))))))))))
 
+(ert-deftest test-self-modifying-plist-get ()
+  :tags '(:crash)
+  (let ((l (list :key 'value)))
+    (should-not-crash (plist-get l :otherkey
+                                 #'(lambda (&rest _) (setcdr l nil))))))
+
+(ert-deftest test-self-modifying-plist-put ()
+  :tags '(:crash)
+  (let ((l (list :key 'value)))
+    (should-not-crash (plist-put l :otherkey 'dummy
+                                 #'(lambda (&rest _) (setcdr l nil))))))
+
 ;;; fns-tests.el ends here

commit d70c8d145a79f91b4cdd5f050a7b0f6cca425596
Author: Pip Cet <[email-masked]>
Date:   Sat Jan 18 13:41:31 2025 +0000

    Fix unlikely crashes for self-modifying plists (bug#75684)
    
    * src/fns.c (Fplist_get): Verify 'tail' is always a cons cell.
    (Fplist_put): Verify 'tail' is always a cons cell.  Use 'prev_cdr' to
    refer to the cons cell which has the value to be modified as its car.
    (plist_put): Analogous changes, to improve readability.

diff --git a/src/fns.c b/src/fns.c
index 07df2a5e90e..c07891771bb 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -2602,11 +2602,12 @@ DEFUN ("plist-get", Fplist_get, Splist_get, 2, 3, 0,
   Lisp_Object tail = plist;
   FOR_EACH_TAIL_SAFE (tail)
     {
-      if (! CONSP (XCDR (tail)))
+      Lisp_Object tail_cdr = XCDR (tail);
+      if (! CONSP (tail_cdr))
 	break;
       if (!NILP (call2 (predicate, XCAR (tail), prop)))
-	return XCAR (XCDR (tail));
-      tail = XCDR (tail);
+	return XCAR (tail_cdr);
+      tail = tail_cdr;
     }
 
   return Qnil;
@@ -2657,27 +2658,27 @@ DEFUN ("plist-put", Fplist_put, Splist_put, 3, 4, 0,
 {
   if (NILP (predicate))
     return plist_put (plist, prop, val);
-  Lisp_Object prev = Qnil, tail = plist;
+  Lisp_Object prev_cdr = Qnil;
+  Lisp_Object tail = plist;
   FOR_EACH_TAIL (tail)
     {
-      if (! CONSP (XCDR (tail)))
+      Lisp_Object tail_cdr = XCDR (tail);
+      if (! CONSP (tail_cdr))
 	break;
-
       if (!NILP (call2 (predicate, XCAR (tail), prop)))
 	{
-	  Fsetcar (XCDR (tail), val);
+	  Fsetcar (tail_cdr, val);
 	  return plist;
 	}
 
-      prev = tail;
-      tail = XCDR (tail);
+      prev_cdr = tail = tail_cdr;
     }
   CHECK_TYPE (NILP (tail), Qplistp, plist);
   Lisp_Object newcell
-    = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR (prev))));
-  if (NILP (prev))
+    = Fcons (prop, Fcons (val, NILP (prev_cdr) ? plist : XCDR (prev_cdr)));
+  if (NILP (prev_cdr))
     return newcell;
-  Fsetcdr (XCDR (prev), newcell);
+  Fsetcdr (prev_cdr, newcell);
   return plist;
 }
 
@@ -2685,10 +2686,12 @@ DEFUN ("plist-put", Fplist_put, Splist_put, 3, 4, 0,
 Lisp_Object
 plist_put (Lisp_Object plist, Lisp_Object prop, Lisp_Object val)
 {
-  Lisp_Object prev = Qnil, tail = plist;
+  Lisp_Object prev_cdr = Qnil;
+  Lisp_Object tail = plist;
   FOR_EACH_TAIL (tail)
     {
-      if (! CONSP (XCDR (tail)))
+      Lisp_Object tail_cdr = XCDR (tail);
+      if (! CONSP (tail_cdr))
 	break;
 
       if (EQ (XCAR (tail), prop))
@@ -2697,15 +2700,14 @@ plist_put (Lisp_Object plist, Lisp_Object prop, Lisp_Object val)
 	  return plist;
 	}
 
-      prev = tail;
-      tail = XCDR (tail);
+      prev_cdr = tail = tail_cdr;;
     }
   CHECK_TYPE (NILP (tail), Qplistp, plist);
   Lisp_Object newcell
-    = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR (prev))));
-  if (NILP (prev))
+    = Fcons (prop, Fcons (val, NILP (prev_cdr) ? plist : XCDR (prev_cdr)));
+  if (NILP (prev_cdr))
     return newcell;
-  Fsetcdr (XCDR (prev), newcell);
+  Fsetcdr (prev_cdr, newcell);
   return plist;
 }