[Emacs-diffs] master 083940a: Fix core dump in substitute-object-in-subtree

[Paul Eggert]

branch: master
commit 083940a93df17c6e50d6523e30d56ca3d179f688
Author: Paul Eggert <address@hidden>
Commit: Paul Eggert <address@hidden>

    Fix core dump in substitute-object-in-subtree
    
    Without this fix, (substitute-object-in-subtree #0=(#0# 'a) 'a)
    would dump core, since the C code would recurse indefinitely through
    the infinite structure.  This patch adds an argument to the function,
    and renames it to lread--substitute-object-in-subtree as the function
    is not general-purpose and should not be relied on by outside code.
    See Bug#23660.
    * src/intervals.c (traverse_intervals_noorder): ARG is now void *,
    not Lisp_Object, so that callers need not cons unnecessarily.
    All callers changed.  Also, remove related #if-0 code that was
    “temporary” in the early 1990s and has not been compilable for
    some time.
    * src/lread.c (struct subst): New type, for substitution closure data.
    (seen_list): Remove this static var, as this info is now part of
    struct subst.  All uses removed.
    (Flread__substitute_object_in_subtree): Rename from
    Fsubstitute_object_in_subtree, and give it a 3rd arg so that it
    doesn’t dump core when called from the top level with an
    already-cyclic structure.  All callers changed.
    (SUBSTITUTE): Remove.  All callers expanded and then simplified.
    (substitute_object_recurse): Take a single argument SUBST rather
    than a pair OBJECT and PLACEHOLDER, so that its address can be
    passed around as part of a closure; this avoids the need for an
    AUTO_CONS call.  All callers changed.  If the COMPLETED component
    is t, treat every subobject as potentially circular.
    (substitute_in_interval): Take a struct subst * rather than a
    Lisp_Object, for the closure data.  All callers changed.
    * test/src/lread-tests.el (lread-lread--substitute-object-in-subtree):
    New test, to check that the core dump does not reoccur.
---
 lisp/emacs-lisp/edebug.el |   2 +-
 src/alloc.c               |   4 +-
 src/intervals.c           |  66 +---------------------------
 src/intervals.h           |   3 +-
 src/lread.c               | 110 +++++++++++++++++++---------------------------
 src/print.c               |   6 +--
 test/src/lread-tests.el   |   6 +++
 7 files changed, 60 insertions(+), 137 deletions(-)

diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index 65e30f8..1494ed1 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -906,7 +906,7 @@ circular objects.  Let `read' read everything else."
                 ;; with the object itself, wherever it occurs.
                 (forward-char 1)
                 (let ((obj (edebug-read-storing-offsets stream)))
-                  (substitute-object-in-subtree obj placeholder)
+                  (lread--substitute-object-in-subtree obj placeholder t)
                   (throw 'return (setf (cdr elem) obj)))))
              ((eq ?# (following-char))
               ;; #n# returns a previously read object.
diff --git a/src/alloc.c b/src/alloc.c
index ac3de83..2d785d5 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -1553,7 +1553,7 @@ make_interval (void)
 /* Mark Lisp objects in interval I.  */
 
 static void
-mark_interval (register INTERVAL i, Lisp_Object dummy)
+mark_interval (INTERVAL i, void *dummy)
 {
   /* Intervals should never be shared.  So, if extra internal checking is
      enabled, GC aborts if it seems to have visited an interval twice.  */
@@ -1567,7 +1567,7 @@ mark_interval (register INTERVAL i, Lisp_Object dummy)
 #define MARK_INTERVAL_TREE(i)                                  \
   do {                                                         \
     if (i && !i->gcmarkbit)                                    \
-      traverse_intervals_noorder (i, mark_interval, Qnil);     \
+      traverse_intervals_noorder (i, mark_interval, NULL);     \
   } while (0)
 
 /***********************************************************************
diff --git a/src/intervals.c b/src/intervals.c
index d17d80a..0089ecb 100644
--- a/src/intervals.c
+++ b/src/intervals.c
@@ -224,7 +224,8 @@ intervals_equal (INTERVAL i0, INTERVAL i1)
    Pass FUNCTION two args: an interval, and ARG.  */
 
 void
-traverse_intervals_noorder (INTERVAL tree, void (*function) (INTERVAL, 
Lisp_Object), Lisp_Object arg)
+traverse_intervals_noorder (INTERVAL tree, void (*function) (INTERVAL, void *),
+                           void *arg)
 {
   /* Minimize stack usage.  */
   while (tree)
@@ -257,69 +258,6 @@ traverse_intervals (INTERVAL tree, ptrdiff_t position,
     }
 }
 
-#if 0
-
-static int icount;
-static int idepth;
-static int zero_length;
-
-/* These functions are temporary, for debugging purposes only.  */
-
-INTERVAL search_interval, found_interval;
-
-void
-check_for_interval (INTERVAL i)
-{
-  if (i == search_interval)
-    {
-      found_interval = i;
-      icount++;
-    }
-}
-
-INTERVAL
-search_for_interval (INTERVAL i, INTERVAL tree)
-{
-  icount = 0;
-  search_interval = i;
-  found_interval = NULL;
-  traverse_intervals_noorder (tree, &check_for_interval, Qnil);
-  return found_interval;
-}
-
-static void
-inc_interval_count (INTERVAL i)
-{
-  icount++;
-  if (LENGTH (i) == 0)
-    zero_length++;
-  if (depth > idepth)
-    idepth = depth;
-}
-
-int
-count_intervals (INTERVAL i)
-{
-  icount = 0;
-  idepth = 0;
-  zero_length = 0;
-  traverse_intervals_noorder (i, &inc_interval_count, Qnil);
-
-  return icount;
-}
-
-static INTERVAL
-root_interval (INTERVAL interval)
-{
-  register INTERVAL i = interval;
-
-  while (! ROOT_INTERVAL_P (i))
-    i = INTERVAL_PARENT (i);
-
-  return i;
-}
-#endif
-
 /* Assuming that a left child exists, perform the following operation:
 
      A           B
diff --git a/src/intervals.h b/src/intervals.h
index a0da6f3..9140e0c 100644
--- a/src/intervals.h
+++ b/src/intervals.h
@@ -242,8 +242,7 @@ extern void traverse_intervals (INTERVAL, ptrdiff_t,
                                 void (*) (INTERVAL, Lisp_Object),
                                 Lisp_Object);
 extern void traverse_intervals_noorder (INTERVAL,
-                                        void (*) (INTERVAL, Lisp_Object),
-                                        Lisp_Object);
+                                       void (*) (INTERVAL, void *), void *);
 extern INTERVAL split_interval_right (INTERVAL, ptrdiff_t);
 extern INTERVAL split_interval_left (INTERVAL, ptrdiff_t);
 extern INTERVAL find_interval (INTERVAL, ptrdiff_t);
diff --git a/src/lread.c b/src/lread.c
index 8e7cd3c..4d1a27d 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -595,6 +595,20 @@ read_emacs_mule_char (int c, int (*readbyte) (int, 
Lisp_Object), Lisp_Object rea
 }
 
 
+/* An in-progress substitution of OBJECT for PLACEHOLDER.  */
+struct subst
+{
+  Lisp_Object object;
+  Lisp_Object placeholder;
+
+  /* Hash table of subobjects of OBJECT that might be circular.  If
+     Qt, all such objects might be circular.  */
+  Lisp_Object completed;
+
+  /* List of subobjects of OBJECT that have already been visited.  */
+  Lisp_Object seen;
+};
+
 static Lisp_Object read_internal_start (Lisp_Object, Lisp_Object,
                                         Lisp_Object);
 static Lisp_Object read0 (Lisp_Object);
@@ -603,9 +617,8 @@ static Lisp_Object read1 (Lisp_Object, int *, bool);
 static Lisp_Object read_list (bool, Lisp_Object);
 static Lisp_Object read_vector (Lisp_Object, bool);
 
-static Lisp_Object substitute_object_recurse (Lisp_Object, Lisp_Object,
-                                              Lisp_Object);
-static void substitute_in_interval (INTERVAL, Lisp_Object);
+static Lisp_Object substitute_object_recurse (struct subst *, Lisp_Object);
+static void substitute_in_interval (INTERVAL, void *);
 
 
 /* Get a character from the tty.  */
@@ -3107,7 +3120,8 @@ read1 (Lisp_Object readcharfun, int *pch, bool 
first_in_list)
                         }
                       else
                         {
-                         Fsubstitute_object_in_subtree (tem, placeholder);
+                         Flread__substitute_object_in_subtree
+                           (tem, placeholder, read_objects_completed);
 
                          /* ...and #n# will use the real value from now on.  */
                          i = hash_lookup (h, number, &hash);
@@ -3513,26 +3527,16 @@ read1 (Lisp_Object readcharfun, int *pch, bool 
first_in_list)
     }
 }
 
-
-/* List of nodes we've seen during substitute_object_in_subtree.  */
-static Lisp_Object seen_list;
-
-DEFUN ("substitute-object-in-subtree", Fsubstitute_object_in_subtree,
-       Ssubstitute_object_in_subtree, 2, 2, 0,
-       doc: /* Replace every reference to PLACEHOLDER in OBJECT with OBJECT.  
*/)
-  (Lisp_Object object, Lisp_Object placeholder)
+DEFUN ("lread--substitute-object-in-subtree",
+       Flread__substitute_object_in_subtree,
+       Slread__substitute_object_in_subtree, 3, 3, 0,
+       doc: /* In OBJECT, replace every occurrence of PLACEHOLDER with OBJECT.
+COMPLETED is a hash table of objects that might be circular, or is t
+if any object might be circular.  */)
+  (Lisp_Object object, Lisp_Object placeholder, Lisp_Object completed)
 {
-  Lisp_Object check_object;
-
-  /* We haven't seen any objects when we start.  */
-  seen_list = Qnil;
-
-  /* Make all the substitutions.  */
-  check_object
-    = substitute_object_recurse (object, placeholder, object);
-
-  /* Clear seen_list because we're done with it.  */
-  seen_list = Qnil;
+  struct subst subst = { object, placeholder, completed, Qnil };
+  Lisp_Object check_object = substitute_object_recurse (&subst, object);
 
   /* The returned object here is expected to always eq the
      original.  */
@@ -3541,26 +3545,12 @@ DEFUN ("substitute-object-in-subtree", 
Fsubstitute_object_in_subtree,
   return Qnil;
 }
 
-/*  Feval doesn't get called from here, so no gc protection is needed.  */
-#define SUBSTITUTE(get_val, set_val)                   \
-  do {                                                 \
-    Lisp_Object old_value = get_val;                   \
-    Lisp_Object true_value                             \
-      = substitute_object_recurse (object, placeholder,        \
-                                  old_value);          \
-                                                       \
-    if (!EQ (old_value, true_value))                   \
-      {                                                        \
-       set_val;                                        \
-      }                                                        \
-  } while (0)
-
 static Lisp_Object
-substitute_object_recurse (Lisp_Object object, Lisp_Object placeholder, 
Lisp_Object subtree)
+substitute_object_recurse (struct subst *subst, Lisp_Object subtree)
 {
   /* If we find the placeholder, return the target object.  */
-  if (EQ (placeholder, subtree))
-    return object;
+  if (EQ (subst->placeholder, subtree))
+    return subst->object;
 
   /* For common object types that can't contain other objects, don't
      bother looking them up; we're done.  */
@@ -3570,15 +3560,16 @@ substitute_object_recurse (Lisp_Object object, 
Lisp_Object placeholder, Lisp_Obj
     return subtree;
 
   /* If we've been to this node before, don't explore it again.  */
-  if (!EQ (Qnil, Fmemq (subtree, seen_list)))
+  if (!EQ (Qnil, Fmemq (subtree, subst->seen)))
     return subtree;
 
   /* If this node can be the entry point to a cycle, remember that
      we've seen it.  It can only be such an entry point if it was made
      by #n=, which means that we can find it as a value in
-     read_objects_completed.  */
-  if (hash_lookup (XHASH_TABLE (read_objects_completed), subtree, NULL) >= 0)
-    seen_list = Fcons (subtree, seen_list);
+     COMPLETED.  */
+  if (EQ (subst->completed, Qt)
+      || hash_lookup (XHASH_TABLE (subst->completed), subtree, NULL) >= 0)
+    subst->seen = Fcons (subtree, subst->seen);
 
   /* Recurse according to subtree's type.
      Every branch must return a Lisp_Object.  */
@@ -3605,19 +3596,15 @@ substitute_object_recurse (Lisp_Object object, 
Lisp_Object placeholder, Lisp_Obj
        if (SUB_CHAR_TABLE_P (subtree))
          i = 2;
        for ( ; i < length; i++)
-         SUBSTITUTE (AREF (subtree, i),
-                     ASET (subtree, i, true_value));
+         ASET (subtree, i,
+               substitute_object_recurse (subst, AREF (subtree, i)));
        return subtree;
       }
 
     case Lisp_Cons:
-      {
-       SUBSTITUTE (XCAR (subtree),
-                   XSETCAR (subtree, true_value));
-       SUBSTITUTE (XCDR (subtree),
-                   XSETCDR (subtree, true_value));
-       return subtree;
-      }
+      XSETCAR (subtree, substitute_object_recurse (subst, XCAR (subtree)));
+      XSETCDR (subtree, substitute_object_recurse (subst, XCDR (subtree)));
+      return subtree;
 
     case Lisp_String:
       {
@@ -3625,11 +3612,8 @@ substitute_object_recurse (Lisp_Object object, 
Lisp_Object placeholder, Lisp_Obj
           substitute_in_interval contains part of the logic.  */
 
        INTERVAL root_interval = string_intervals (subtree);
-       AUTO_CONS (arg, object, placeholder);
-
        traverse_intervals_noorder (root_interval,
-                                   &substitute_in_interval, arg);
-
+                                   substitute_in_interval, subst);
        return subtree;
       }
 
@@ -3641,12 +3625,10 @@ substitute_object_recurse (Lisp_Object object, 
Lisp_Object placeholder, Lisp_Obj
 
 /*  Helper function for substitute_object_recurse.  */
 static void
-substitute_in_interval (INTERVAL interval, Lisp_Object arg)
+substitute_in_interval (INTERVAL interval, void *arg)
 {
-  Lisp_Object object      = Fcar (arg);
-  Lisp_Object placeholder = Fcdr (arg);
-
-  SUBSTITUTE (interval->plist, set_interval_plist (interval, true_value));
+  set_interval_plist (interval,
+                     substitute_object_recurse (arg, interval->plist));
 }
 
 
@@ -4744,7 +4726,7 @@ syms_of_lread (void)
 {
   defsubr (&Sread);
   defsubr (&Sread_from_string);
-  defsubr (&Ssubstitute_object_in_subtree);
+  defsubr (&Slread__substitute_object_in_subtree);
   defsubr (&Sintern);
   defsubr (&Sintern_soft);
   defsubr (&Sunintern);
@@ -5057,8 +5039,6 @@ that are loaded before your customizations are read!  */);
   read_objects_map = Qnil;
   staticpro (&read_objects_completed);
   read_objects_completed = Qnil;
-  staticpro (&seen_list);
-  seen_list = Qnil;
 
   Vloads_in_progress = Qnil;
   staticpro (&Vloads_in_progress);
diff --git a/src/print.c b/src/print.c
index 50c75d7..b6ea3ff 100644
--- a/src/print.c
+++ b/src/print.c
@@ -566,7 +566,7 @@ temp_output_buffer_setup (const char *bufname)
 
 static void print (Lisp_Object, Lisp_Object, bool);
 static void print_preprocess (Lisp_Object);
-static void print_preprocess_string (INTERVAL, Lisp_Object);
+static void print_preprocess_string (INTERVAL, void *);
 static void print_object (Lisp_Object, Lisp_Object, bool);
 
 DEFUN ("terpri", Fterpri, Sterpri, 0, 2, 0,
@@ -1214,7 +1214,7 @@ print_preprocess (Lisp_Object obj)
        case Lisp_String:
          /* A string may have text properties, which can be circular.  */
          traverse_intervals_noorder (string_intervals (obj),
-                                     print_preprocess_string, Qnil);
+                                     print_preprocess_string, NULL);
          break;
 
        case Lisp_Cons:
@@ -1263,7 +1263,7 @@ Fills `print-number-table'.  */)
 }
 
 static void
-print_preprocess_string (INTERVAL interval, Lisp_Object arg)
+print_preprocess_string (INTERVAL interval, void *arg)
 {
   print_preprocess (interval->plist);
 }
diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el
index 98cbb6a..a0a317f 100644
--- a/test/src/lread-tests.el
+++ b/test/src/lread-tests.el
@@ -164,4 +164,10 @@ literals (Bug#20852)."
                    (concat (format-message "Loading `%s': " file-name)
                            "old-style backquotes detected!")))))
 
+(ert-deftest lread-lread--substitute-object-in-subtree ()
+  (let ((x (cons 0 1)))
+    (setcar x x)
+    (lread--substitute-object-in-subtree x 1 t)
+    (should (eq x (cdr x)))))
+
 ;;; lread-tests.el ends here