Commit 083940a9 authored by Paul Eggert's avatar Paul Eggert

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.
parent ce6773aa
...@@ -906,7 +906,7 @@ circular objects. Let `read' read everything else." ...@@ -906,7 +906,7 @@ circular objects. Let `read' read everything else."
;; with the object itself, wherever it occurs. ;; with the object itself, wherever it occurs.
(forward-char 1) (forward-char 1)
(let ((obj (edebug-read-storing-offsets stream))) (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))))) (throw 'return (setf (cdr elem) obj)))))
((eq ?# (following-char)) ((eq ?# (following-char))
;; #n# returns a previously read object. ;; #n# returns a previously read object.
......
...@@ -1553,7 +1553,7 @@ make_interval (void) ...@@ -1553,7 +1553,7 @@ make_interval (void)
/* Mark Lisp objects in interval I. */ /* Mark Lisp objects in interval I. */
static void 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 /* Intervals should never be shared. So, if extra internal checking is
enabled, GC aborts if it seems to have visited an interval twice. */ enabled, GC aborts if it seems to have visited an interval twice. */
...@@ -1567,7 +1567,7 @@ mark_interval (register INTERVAL i, Lisp_Object dummy) ...@@ -1567,7 +1567,7 @@ mark_interval (register INTERVAL i, Lisp_Object dummy)
#define MARK_INTERVAL_TREE(i) \ #define MARK_INTERVAL_TREE(i) \
do { \ do { \
if (i && !i->gcmarkbit) \ if (i && !i->gcmarkbit) \
traverse_intervals_noorder (i, mark_interval, Qnil); \ traverse_intervals_noorder (i, mark_interval, NULL); \
} while (0) } while (0)
/*********************************************************************** /***********************************************************************
......
...@@ -224,7 +224,8 @@ intervals_equal (INTERVAL i0, INTERVAL i1) ...@@ -224,7 +224,8 @@ intervals_equal (INTERVAL i0, INTERVAL i1)
Pass FUNCTION two args: an interval, and ARG. */ Pass FUNCTION two args: an interval, and ARG. */
void 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. */ /* Minimize stack usage. */
while (tree) while (tree)
...@@ -257,69 +258,6 @@ traverse_intervals (INTERVAL tree, ptrdiff_t position, ...@@ -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: /* Assuming that a left child exists, perform the following operation:
A B A B
......
...@@ -242,8 +242,7 @@ extern void traverse_intervals (INTERVAL, ptrdiff_t, ...@@ -242,8 +242,7 @@ extern void traverse_intervals (INTERVAL, ptrdiff_t,
void (*) (INTERVAL, Lisp_Object), void (*) (INTERVAL, Lisp_Object),
Lisp_Object); Lisp_Object);
extern void traverse_intervals_noorder (INTERVAL, extern void traverse_intervals_noorder (INTERVAL,
void (*) (INTERVAL, Lisp_Object), void (*) (INTERVAL, void *), void *);
Lisp_Object);
extern INTERVAL split_interval_right (INTERVAL, ptrdiff_t); extern INTERVAL split_interval_right (INTERVAL, ptrdiff_t);
extern INTERVAL split_interval_left (INTERVAL, ptrdiff_t); extern INTERVAL split_interval_left (INTERVAL, ptrdiff_t);
extern INTERVAL find_interval (INTERVAL, ptrdiff_t); extern INTERVAL find_interval (INTERVAL, ptrdiff_t);
......
...@@ -595,6 +595,20 @@ read_emacs_mule_char (int c, int (*readbyte) (int, Lisp_Object), Lisp_Object rea ...@@ -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, static Lisp_Object read_internal_start (Lisp_Object, Lisp_Object,
Lisp_Object); Lisp_Object);
static Lisp_Object read0 (Lisp_Object); static Lisp_Object read0 (Lisp_Object);
...@@ -603,9 +617,8 @@ static Lisp_Object read1 (Lisp_Object, int *, bool); ...@@ -603,9 +617,8 @@ static Lisp_Object read1 (Lisp_Object, int *, bool);
static Lisp_Object read_list (bool, Lisp_Object); static Lisp_Object read_list (bool, Lisp_Object);
static Lisp_Object read_vector (Lisp_Object, bool); static Lisp_Object read_vector (Lisp_Object, bool);
static Lisp_Object substitute_object_recurse (Lisp_Object, Lisp_Object, static Lisp_Object substitute_object_recurse (struct subst *, Lisp_Object);
Lisp_Object); static void substitute_in_interval (INTERVAL, void *);
static void substitute_in_interval (INTERVAL, Lisp_Object);
/* Get a character from the tty. */ /* Get a character from the tty. */
...@@ -3107,7 +3120,8 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) ...@@ -3107,7 +3120,8 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
} }
else 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. */ /* ...and #n# will use the real value from now on. */
i = hash_lookup (h, number, &hash); i = hash_lookup (h, number, &hash);
...@@ -3513,26 +3527,16 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) ...@@ -3513,26 +3527,16 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
} }
} }
DEFUN ("lread--substitute-object-in-subtree",
/* List of nodes we've seen during substitute_object_in_subtree. */ Flread__substitute_object_in_subtree,
static Lisp_Object seen_list; Slread__substitute_object_in_subtree, 3, 3, 0,
doc: /* In OBJECT, replace every occurrence of PLACEHOLDER with OBJECT.
DEFUN ("substitute-object-in-subtree", Fsubstitute_object_in_subtree, COMPLETED is a hash table of objects that might be circular, or is t
Ssubstitute_object_in_subtree, 2, 2, 0, if any object might be circular. */)
doc: /* Replace every reference to PLACEHOLDER in OBJECT with OBJECT. */) (Lisp_Object object, Lisp_Object placeholder, Lisp_Object completed)
(Lisp_Object object, Lisp_Object placeholder)
{ {
Lisp_Object check_object; struct subst subst = { object, placeholder, completed, Qnil };
Lisp_Object check_object = substitute_object_recurse (&subst, 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;
/* The returned object here is expected to always eq the /* The returned object here is expected to always eq the
original. */ original. */
...@@ -3541,26 +3545,12 @@ DEFUN ("substitute-object-in-subtree", Fsubstitute_object_in_subtree, ...@@ -3541,26 +3545,12 @@ DEFUN ("substitute-object-in-subtree", Fsubstitute_object_in_subtree,
return Qnil; 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 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 we find the placeholder, return the target object. */
if (EQ (placeholder, subtree)) if (EQ (subst->placeholder, subtree))
return object; return subst->object;
/* For common object types that can't contain other objects, don't /* For common object types that can't contain other objects, don't
bother looking them up; we're done. */ bother looking them up; we're done. */
...@@ -3570,15 +3560,16 @@ substitute_object_recurse (Lisp_Object object, Lisp_Object placeholder, Lisp_Obj ...@@ -3570,15 +3560,16 @@ substitute_object_recurse (Lisp_Object object, Lisp_Object placeholder, Lisp_Obj
return subtree; return subtree;
/* If we've been to this node before, don't explore it again. */ /* 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; return subtree;
/* If this node can be the entry point to a cycle, remember that /* 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 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 by #n=, which means that we can find it as a value in
read_objects_completed. */ COMPLETED. */
if (hash_lookup (XHASH_TABLE (read_objects_completed), subtree, NULL) >= 0) if (EQ (subst->completed, Qt)
seen_list = Fcons (subtree, seen_list); || hash_lookup (XHASH_TABLE (subst->completed), subtree, NULL) >= 0)
subst->seen = Fcons (subtree, subst->seen);
/* Recurse according to subtree's type. /* Recurse according to subtree's type.
Every branch must return a Lisp_Object. */ Every branch must return a Lisp_Object. */
...@@ -3605,19 +3596,15 @@ substitute_object_recurse (Lisp_Object object, Lisp_Object placeholder, Lisp_Obj ...@@ -3605,19 +3596,15 @@ substitute_object_recurse (Lisp_Object object, Lisp_Object placeholder, Lisp_Obj
if (SUB_CHAR_TABLE_P (subtree)) if (SUB_CHAR_TABLE_P (subtree))
i = 2; i = 2;
for ( ; i < length; i++) for ( ; i < length; i++)
SUBSTITUTE (AREF (subtree, i), ASET (subtree, i,
ASET (subtree, i, true_value)); substitute_object_recurse (subst, AREF (subtree, i)));
return subtree; return subtree;
} }
case Lisp_Cons: case Lisp_Cons:
{ XSETCAR (subtree, substitute_object_recurse (subst, XCAR (subtree)));
SUBSTITUTE (XCAR (subtree), XSETCDR (subtree, substitute_object_recurse (subst, XCDR (subtree)));
XSETCAR (subtree, true_value)); return subtree;
SUBSTITUTE (XCDR (subtree),
XSETCDR (subtree, true_value));
return subtree;
}
case Lisp_String: case Lisp_String:
{ {
...@@ -3625,11 +3612,8 @@ substitute_object_recurse (Lisp_Object object, Lisp_Object placeholder, Lisp_Obj ...@@ -3625,11 +3612,8 @@ substitute_object_recurse (Lisp_Object object, Lisp_Object placeholder, Lisp_Obj
substitute_in_interval contains part of the logic. */ substitute_in_interval contains part of the logic. */
INTERVAL root_interval = string_intervals (subtree); INTERVAL root_interval = string_intervals (subtree);
AUTO_CONS (arg, object, placeholder);
traverse_intervals_noorder (root_interval, traverse_intervals_noorder (root_interval,
&substitute_in_interval, arg); substitute_in_interval, subst);
return subtree; return subtree;
} }
...@@ -3641,12 +3625,10 @@ substitute_object_recurse (Lisp_Object object, Lisp_Object placeholder, Lisp_Obj ...@@ -3641,12 +3625,10 @@ substitute_object_recurse (Lisp_Object object, Lisp_Object placeholder, Lisp_Obj
/* Helper function for substitute_object_recurse. */ /* Helper function for substitute_object_recurse. */
static void static void
substitute_in_interval (INTERVAL interval, Lisp_Object arg) substitute_in_interval (INTERVAL interval, void *arg)
{ {
Lisp_Object object = Fcar (arg); set_interval_plist (interval,
Lisp_Object placeholder = Fcdr (arg); substitute_object_recurse (arg, interval->plist));
SUBSTITUTE (interval->plist, set_interval_plist (interval, true_value));
} }
...@@ -4744,7 +4726,7 @@ syms_of_lread (void) ...@@ -4744,7 +4726,7 @@ syms_of_lread (void)
{ {
defsubr (&Sread); defsubr (&Sread);
defsubr (&Sread_from_string); defsubr (&Sread_from_string);
defsubr (&Ssubstitute_object_in_subtree); defsubr (&Slread__substitute_object_in_subtree);
defsubr (&Sintern); defsubr (&Sintern);
defsubr (&Sintern_soft); defsubr (&Sintern_soft);
defsubr (&Sunintern); defsubr (&Sunintern);
...@@ -5057,8 +5039,6 @@ that are loaded before your customizations are read! */); ...@@ -5057,8 +5039,6 @@ that are loaded before your customizations are read! */);
read_objects_map = Qnil; read_objects_map = Qnil;
staticpro (&read_objects_completed); staticpro (&read_objects_completed);
read_objects_completed = Qnil; read_objects_completed = Qnil;
staticpro (&seen_list);
seen_list = Qnil;
Vloads_in_progress = Qnil; Vloads_in_progress = Qnil;
staticpro (&Vloads_in_progress); staticpro (&Vloads_in_progress);
......
...@@ -566,7 +566,7 @@ temp_output_buffer_setup (const char *bufname) ...@@ -566,7 +566,7 @@ temp_output_buffer_setup (const char *bufname)
static void print (Lisp_Object, Lisp_Object, bool); static void print (Lisp_Object, Lisp_Object, bool);
static void print_preprocess (Lisp_Object); 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); static void print_object (Lisp_Object, Lisp_Object, bool);
DEFUN ("terpri", Fterpri, Sterpri, 0, 2, 0, DEFUN ("terpri", Fterpri, Sterpri, 0, 2, 0,
...@@ -1214,7 +1214,7 @@ print_preprocess (Lisp_Object obj) ...@@ -1214,7 +1214,7 @@ print_preprocess (Lisp_Object obj)
case Lisp_String: case Lisp_String:
/* A string may have text properties, which can be circular. */ /* A string may have text properties, which can be circular. */
traverse_intervals_noorder (string_intervals (obj), traverse_intervals_noorder (string_intervals (obj),
print_preprocess_string, Qnil); print_preprocess_string, NULL);
break; break;
case Lisp_Cons: case Lisp_Cons:
...@@ -1263,7 +1263,7 @@ Fills `print-number-table'. */) ...@@ -1263,7 +1263,7 @@ Fills `print-number-table'. */)
} }
static void static void
print_preprocess_string (INTERVAL interval, Lisp_Object arg) print_preprocess_string (INTERVAL interval, void *arg)
{ {
print_preprocess (interval->plist); print_preprocess (interval->plist);
} }
......
...@@ -164,4 +164,10 @@ literals (Bug#20852)." ...@@ -164,4 +164,10 @@ literals (Bug#20852)."
(concat (format-message "Loading `%s': " file-name) (concat (format-message "Loading `%s': " file-name)
"old-style backquotes detected!"))))) "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 ;;; lread-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