procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fix core dump in substitute-object-in-subtree

Browse source 
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.
This commit is contained in:
Paul Eggert 2017-07-09 16:04:02 -07:00
parent ce6773aad5
commit 083940a93d
7 changed files with 60 additions and 137 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
lisp/emacs-lisp/edebug.el
View file

@ -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.

4
src/alloc.c
View file

@ -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)
/***********************************************************************

66
src/intervals.c
View file

@ -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

3
src/intervals.h
View file

@ -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);

110
src/lread.c
View file

@ -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);

6
src/print.c
View file

@ -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);
}

6
test/src/lread-tests.el
View file

@ -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