From: Mattias Engdegård Date: Fri, 13 May 2022 11:36:13 +0000 (+0200) Subject: Make printing mostly non-recursive (bug#55481) X-Git-Tag: emacs-29.0.90~1910^2~606 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=97400c4c2446f00ee0783249b9c4f1fbfaf65fb2;p=emacs.git Make printing mostly non-recursive (bug#55481) Introduce explicit stacks for traversing common data types during printing: conses, vectors, records, byte-code, hash-tables and char-tables, all previously traversed using recursion in C. This greatly reduces the risk of crashing Emacs from C stack overflow when printing deeply nested data. * src/print.c (Fprinc, print, PRINT_CIRCLE_CANDIDATE_P): Special-case Fprinc with a plain string argument to eliminate the need for keeping track of print_depth during the preprocessing phase. This also improves performance. (struct print_pp_entry, struct print_pp_stack, ppstack) (grow_pp_stack, pp_stack_push_value, pp_stack_push_values) (pp_stack_empty_p, pp_stack_pop): New stack for preprocessing. (print_preprocess): Make mostly nonrecursive, except for string properties. (enum print_entry_type, struct print_stack_entry) (struct print_stack, prstack, grow_print_stack) (print_stack_push, print_stack_push_vector): New stack for printing. (print_vectorlike, print_object): Make mostly nonrecursive, except for string properties and some less heavily used types. * test/src/print-tests.el (print-deeply-nested): New test. --- diff --git a/src/print.c b/src/print.c index 55f4c2345a3..da4869e8fbe 100644 --- a/src/print.c +++ b/src/print.c @@ -834,7 +834,13 @@ is used instead. */) if (NILP (printcharfun)) printcharfun = Vstandard_output; PRINTPREPARE; - print (object, printcharfun, 0); + if (STRINGP (object) + && !string_intervals (object) + && NILP (Vprint_continuous_numbering)) + /* fast path for plain strings */ + print_string (object, printcharfun); + else + print (object, printcharfun, 0); PRINTFINISH; return object; } @@ -1249,7 +1255,6 @@ print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) { /* Construct Vprint_number_table. This increments print_number_index for the objects added. */ - print_depth = 0; print_preprocess (obj); if (HASH_TABLE_P (Vprint_number_table)) @@ -1273,10 +1278,7 @@ print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) } #define PRINT_CIRCLE_CANDIDATE_P(obj) \ - ((STRINGP (obj) \ - && (string_intervals (obj) \ - || print_depth > 1 \ - || !NILP (Vprint_continuous_numbering))) \ + (STRINGP (obj) \ || CONSP (obj) \ || (VECTORLIKEP (obj) \ && (VECTORP (obj) || COMPILEDP (obj) \ @@ -1287,6 +1289,78 @@ print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) && SYMBOLP (obj) \ && !SYMBOL_INTERNED_P (obj))) +/* The print preprocess stack, used to traverse data structures. */ + +struct print_pp_entry { + ptrdiff_t n; /* number of values, or 0 if a single value */ + union { + Lisp_Object value; /* when n = 0 */ + Lisp_Object *values; /* when n > 0 */ + } u; +}; + +struct print_pp_stack { + struct print_pp_entry *stack; /* base of stack */ + ptrdiff_t size; /* allocated size in entries */ + ptrdiff_t sp; /* current number of entries */ +}; + +static struct print_pp_stack ppstack = {NULL, 0, 0}; + +NO_INLINE static void +grow_pp_stack (void) +{ + struct print_pp_stack *ps = &ppstack; + eassert (ps->sp == ps->size); + ps->stack = xpalloc (ps->stack, &ps->size, 1, -1, sizeof *ps->stack); + eassert (ps->sp < ps->size); +} + +static inline void +pp_stack_push_value (Lisp_Object value) +{ + if (ppstack.sp >= ppstack.size) + grow_pp_stack (); + ppstack.stack[ppstack.sp++] = (struct print_pp_entry){.n = 0, + .u.value = value}; +} + +static inline void +pp_stack_push_values (Lisp_Object *values, ptrdiff_t n) +{ + eassume (n >= 0); + if (n == 0) + return; + if (ppstack.sp >= ppstack.size) + grow_pp_stack (); + ppstack.stack[ppstack.sp++] = (struct print_pp_entry){.n = n, + .u.values = values}; +} + +static inline bool +pp_stack_empty_p (void) +{ + return ppstack.sp <= 0; +} + +static inline Lisp_Object +pp_stack_pop (void) +{ + eassume (!pp_stack_empty_p ()); + struct print_pp_entry *e = &ppstack.stack[ppstack.sp - 1]; + if (e->n == 0) /* single value */ + { + --ppstack.sp; + return e->u.value; + } + /* Array of values: pop them left to right, which seems to be slightly + faster than right to left. */ + e->n--; + if (e->n == 0) + --ppstack.sp; /* last value consumed */ + return (++e->u.values)[-1]; +} + /* Construct Vprint_number_table for the print-circle feature according to the structure of OBJ. OBJ itself and all its elements will be added to Vprint_number_table recursively if it is a list, @@ -1298,86 +1372,81 @@ print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) static void print_preprocess (Lisp_Object obj) { - int i; - ptrdiff_t size; - int loop_count = 0; - Lisp_Object halftail; - eassert (!NILP (Vprint_circle)); + ptrdiff_t base_sp = ppstack.sp; - print_depth++; - halftail = obj; - - loop: - if (PRINT_CIRCLE_CANDIDATE_P (obj)) + for (;;) { - if (!HASH_TABLE_P (Vprint_number_table)) - Vprint_number_table = CALLN (Fmake_hash_table, QCtest, Qeq); - - Lisp_Object num = Fgethash (obj, Vprint_number_table, Qnil); - if (!NILP (num) - /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym, - always print the gensym with a number. This is a special for - the lisp function byte-compile-output-docform. */ - || (!NILP (Vprint_continuous_numbering) - && SYMBOLP (obj) - && !SYMBOL_INTERNED_P (obj))) - { /* OBJ appears more than once. Let's remember that. */ - if (!FIXNUMP (num)) - { - print_number_index++; - /* Negative number indicates it hasn't been printed yet. */ - Fputhash (obj, make_fixnum (- print_number_index), - Vprint_number_table); + if (PRINT_CIRCLE_CANDIDATE_P (obj)) + { + if (!HASH_TABLE_P (Vprint_number_table)) + Vprint_number_table = CALLN (Fmake_hash_table, QCtest, Qeq); + + Lisp_Object num = Fgethash (obj, Vprint_number_table, Qnil); + if (!NILP (num) + /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym, + always print the gensym with a number. This is a special for + the lisp function byte-compile-output-docform. */ + || (!NILP (Vprint_continuous_numbering) + && SYMBOLP (obj) + && !SYMBOL_INTERNED_P (obj))) + { /* OBJ appears more than once. Let's remember that. */ + if (!FIXNUMP (num)) + { + print_number_index++; + /* Negative number indicates it hasn't been printed yet. */ + Fputhash (obj, make_fixnum (- print_number_index), + Vprint_number_table); + } } - print_depth--; - return; - } - else - /* OBJ is not yet recorded. Let's add to the table. */ - Fputhash (obj, Qt, Vprint_number_table); + else + { + /* OBJ is not yet recorded. Let's add to the table. */ + Fputhash (obj, Qt, Vprint_number_table); - switch (XTYPE (obj)) - { - case Lisp_String: - /* A string may have text properties, which can be circular. */ - traverse_intervals_noorder (string_intervals (obj), - print_preprocess_string, NULL); - break; + switch (XTYPE (obj)) + { + case Lisp_String: + /* A string may have text properties, + which can be circular. */ + traverse_intervals_noorder (string_intervals (obj), + print_preprocess_string, NULL); + break; - case Lisp_Cons: - /* Use HALFTAIL and LOOP_COUNT to detect circular lists, - just as in print_object. */ - if (loop_count && EQ (obj, halftail)) - break; - print_preprocess (XCAR (obj)); - obj = XCDR (obj); - loop_count++; - if (!(loop_count & 1)) - halftail = XCDR (halftail); - goto loop; - - case Lisp_Vectorlike: - size = ASIZE (obj); - if (size & PSEUDOVECTOR_FLAG) - size &= PSEUDOVECTOR_SIZE_MASK; - for (i = (SUB_CHAR_TABLE_P (obj) - ? SUB_CHAR_TABLE_OFFSET : 0); i < size; i++) - print_preprocess (AREF (obj, i)); - if (HASH_TABLE_P (obj)) - { /* For hash tables, the key_and_value slot is past - `size' because it needs to be marked specially in case - the table is weak. */ - struct Lisp_Hash_Table *h = XHASH_TABLE (obj); - print_preprocess (h->key_and_value); - } - break; + case Lisp_Cons: + if (!NILP (XCDR (obj))) + pp_stack_push_value (XCDR (obj)); + obj = XCAR (obj); + continue; - default: - break; + case Lisp_Vectorlike: + { + struct Lisp_Vector *vec = XVECTOR (obj); + ptrdiff_t size = ASIZE (obj); + if (size & PSEUDOVECTOR_FLAG) + size &= PSEUDOVECTOR_SIZE_MASK; + ptrdiff_t start = (SUB_CHAR_TABLE_P (obj) + ? SUB_CHAR_TABLE_OFFSET : 0); + pp_stack_push_values (vec->contents + start, size - start); + if (HASH_TABLE_P (obj)) + { + struct Lisp_Hash_Table *h = XHASH_TABLE (obj); + obj = h->key_and_value; + continue; + } + break; + } + + default: + break; + } + } } + + if (ppstack.sp <= base_sp) + break; + obj = pp_stack_pop (); } - print_depth--; } DEFUN ("print--preprocess", Fprint_preprocess, Sprint_preprocess, 1, 1, 0, @@ -1569,162 +1638,6 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, } return true; - case PVEC_HASH_TABLE: - { - struct Lisp_Hash_Table *h = XHASH_TABLE (obj); - /* Implement a readable output, e.g.: - #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */ - /* Always print the size. */ - int len = sprintf (buf, "#s(hash-table size %"pD"d", - HASH_TABLE_SIZE (h)); - strout (buf, len, len, printcharfun); - - if (!NILP (h->test.name)) - { - print_c_string (" test ", printcharfun); - print_object (h->test.name, printcharfun, escapeflag); - } - - if (!NILP (h->weak)) - { - print_c_string (" weakness ", printcharfun); - print_object (h->weak, printcharfun, escapeflag); - } - - print_c_string (" rehash-size ", printcharfun); - print_object (Fhash_table_rehash_size (obj), - printcharfun, escapeflag); - - print_c_string (" rehash-threshold ", printcharfun); - print_object (Fhash_table_rehash_threshold (obj), - printcharfun, escapeflag); - - if (h->purecopy) - { - print_c_string (" purecopy ", printcharfun); - print_object (h->purecopy ? Qt : Qnil, printcharfun, escapeflag); - } - - print_c_string (" data ", printcharfun); - - /* Print the data here as a plist. */ - ptrdiff_t real_size = HASH_TABLE_SIZE (h); - ptrdiff_t size = h->count; - - /* Don't print more elements than the specified maximum. */ - if (FIXNATP (Vprint_length) && XFIXNAT (Vprint_length) < size) - size = XFIXNAT (Vprint_length); - - printchar ('(', printcharfun); - ptrdiff_t j = 0; - for (ptrdiff_t i = 0; i < real_size; i++) - { - Lisp_Object key = HASH_KEY (h, i); - if (!EQ (key, Qunbound)) - { - if (j++) printchar (' ', printcharfun); - print_object (key, printcharfun, escapeflag); - printchar (' ', printcharfun); - print_object (HASH_VALUE (h, i), printcharfun, escapeflag); - if (j == size) - break; - } - } - - if (j < h->count) - { - if (j) - printchar (' ', printcharfun); - print_c_string ("...", printcharfun); - } - - print_c_string ("))", printcharfun); - } - return true; - - case PVEC_RECORD: - { - ptrdiff_t size = PVSIZE (obj); - - /* Don't print more elements than the specified maximum. */ - ptrdiff_t n - = (FIXNATP (Vprint_length) && XFIXNAT (Vprint_length) < size - ? XFIXNAT (Vprint_length) : size); - - print_c_string ("#s(", printcharfun); - for (ptrdiff_t i = 0; i < n; i ++) - { - if (i) printchar (' ', printcharfun); - print_object (AREF (obj, i), printcharfun, escapeflag); - } - if (n < size) - print_c_string (" ...", printcharfun); - printchar (')', printcharfun); - } - return true; - - case PVEC_SUB_CHAR_TABLE: - case PVEC_COMPILED: - case PVEC_CHAR_TABLE: - case PVEC_NORMAL_VECTOR: - { - ptrdiff_t size = ASIZE (obj); - if (COMPILEDP (obj)) - { - printchar ('#', printcharfun); - size &= PSEUDOVECTOR_SIZE_MASK; - } - if (CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj)) - { - /* Print a char-table as if it were a vector, - lumping the parent and default slots in with the - character slots. But add #^ as a prefix. */ - - /* Make each lowest sub_char_table start a new line. - Otherwise we'll make a line extremely long, which - results in slow redisplay. */ - if (SUB_CHAR_TABLE_P (obj) - && XSUB_CHAR_TABLE (obj)->depth == 3) - printchar ('\n', printcharfun); - print_c_string ("#^", printcharfun); - if (SUB_CHAR_TABLE_P (obj)) - printchar ('^', printcharfun); - size &= PSEUDOVECTOR_SIZE_MASK; - } - if (size & PSEUDOVECTOR_FLAG) - return false; - - printchar ('[', printcharfun); - - int idx = SUB_CHAR_TABLE_P (obj) ? SUB_CHAR_TABLE_OFFSET : 0; - Lisp_Object tem; - ptrdiff_t real_size = size; - - /* For a sub char-table, print heading non-Lisp data first. */ - if (SUB_CHAR_TABLE_P (obj)) - { - int i = sprintf (buf, "%d %d", XSUB_CHAR_TABLE (obj)->depth, - XSUB_CHAR_TABLE (obj)->min_char); - strout (buf, i, i, printcharfun); - } - - /* Don't print more elements than the specified maximum. */ - if (FIXNATP (Vprint_length) - && XFIXNAT (Vprint_length) < size) - size = XFIXNAT (Vprint_length); - - for (int i = idx; i < size; i++) - { - if (i) printchar (' ', printcharfun); - tem = AREF (obj, i); - print_object (tem, printcharfun, escapeflag); - } - if (size < real_size) - print_c_string (" ...", printcharfun); - printchar (']', printcharfun); - } - return true; - default: break; } @@ -2103,32 +2016,118 @@ named_escape (int i) return 0; } +enum print_entry_type { + PE_list, /* print rest of list */ + PE_rbrac, /* print ")" */ + PE_vector, /* print rest of vector */ + PE_hash, /* print rest of hash data */ +}; + +struct print_stack_entry { + enum print_entry_type type; + union { + struct { + Lisp_Object last; /* cons whose car was just printed */ + ptrdiff_t idx; /* index of next element */ + intmax_t maxlen; /* max length (from Vprint_length) */ + /* state for Brent cycle detection */ + Lisp_Object tortoise; /* slow pointer */ + ptrdiff_t n; /* tortoise step countdown */ + ptrdiff_t m; /* tortoise step period */ + } list; + struct { + Lisp_Object obj; /* object to print after " . " */ + } dotted_cdr; + struct { + Lisp_Object obj; /* vector object */ + ptrdiff_t size; /* length of vector */ + ptrdiff_t idx; /* index of next element */ + const char *end; /* string to print at end */ + bool truncated; /* whether to print "..." before end */ + } vector; + struct { + Lisp_Object obj; /* hash-table object */ + ptrdiff_t nobjs; /* number of keys and values to print */ + ptrdiff_t idx; /* index of key-value pair */ + ptrdiff_t printed; /* number of keys and values printed */ + bool truncated; /* whether to print "..." before end */ + } hash; + } u; +}; + +struct print_stack { + struct print_stack_entry *stack; /* base of stack */ + ptrdiff_t size; /* allocated size in entries */ + ptrdiff_t sp; /* current number of entries */ +}; + +static struct print_stack prstack = {NULL, 0, 0}; + +NO_INLINE static void +grow_print_stack (void) +{ + struct print_stack *ps = &prstack; + eassert (ps->sp == ps->size); + ps->stack = xpalloc (ps->stack, &ps->size, 1, -1, sizeof *ps->stack); + eassert (ps->sp < ps->size); +} + +static inline void +print_stack_push (struct print_stack_entry e) +{ + if (prstack.sp >= prstack.size) + grow_print_stack (); + prstack.stack[prstack.sp++] = e; +} + +static void +print_stack_push_vector (const char *lbrac, const char *rbrac, + Lisp_Object obj, ptrdiff_t start, ptrdiff_t size, + Lisp_Object printcharfun) +{ + print_c_string (lbrac, printcharfun); + + ptrdiff_t print_size = ((FIXNATP (Vprint_length) + && XFIXNAT (Vprint_length) < size) + ? XFIXNAT (Vprint_length) : size); + print_stack_push ((struct print_stack_entry){ + .type = PE_vector, + .u.vector.obj = obj, + .u.vector.size = print_size, + .u.vector.idx = start, + .u.vector.end = rbrac, + .u.vector.truncated = (print_size < size), + }); +} + static void print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) { + ptrdiff_t base_depth = print_depth; + ptrdiff_t base_sp = prstack.sp; char buf[max (sizeof "from..to..in " + 2 * INT_STRLEN_BOUND (EMACS_INT), max (sizeof " . #" + INT_STRLEN_BOUND (intmax_t), max ((sizeof " with data 0x" + (sizeof (uintmax_t) * CHAR_BIT + 4 - 1) / 4), 40)))]; current_thread->stack_top = buf; + + print_obj: maybe_quit (); /* Detect circularities and truncate them. */ if (NILP (Vprint_circle)) { /* Simple but incomplete way. */ - int i; - if (print_depth >= PRINT_CIRCLE) error ("Apparently circular structure being printed"); - for (i = 0; i < print_depth; i++) + for (int i = 0; i < print_depth; i++) if (BASE_EQ (obj, being_printed[i])) { int len = sprintf (buf, "#%d", i); strout (buf, len, len, printcharfun); - return; + goto next_obj; } being_printed[print_depth] = obj; } @@ -2152,7 +2151,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) /* Just print #n# if OBJ has already been printed. */ int len = sprintf (buf, "#%"pI"d#", n); strout (buf, len, len, printcharfun); - return; + goto next_obj; } } } @@ -2226,7 +2225,8 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) for (i = 0, i_byte = 0; i_byte < size_byte;) { /* Here, we must convert each multi-byte form to the - corresponding character code before handing it to printchar. */ + corresponding character code before handing it to + printchar. */ int c = fetch_string_char_advance (obj, &i, &i_byte); maybe_quit (); @@ -2246,7 +2246,8 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) else if (multibyte && ! ASCII_CHAR_P (c) && print_escape_multibyte) { - /* When requested, print multibyte chars using hex escapes. */ + /* When requested, print multibyte chars using + hex escapes. */ char outbuf[sizeof "\\x" + INT_STRLEN_BOUND (c)]; int len = sprintf (outbuf, "\\x%04x", c + 0u); strout (outbuf, len, len, printcharfun); @@ -2357,14 +2358,22 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) && EQ (XCAR (obj), Qquote)) { printchar ('\'', printcharfun); - print_object (XCAR (XCDR (obj)), printcharfun, escapeflag); + obj = XCAR (XCDR (obj)); + --print_depth; /* tail recursion */ + goto print_obj; } else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj))) && EQ (XCAR (obj), Qfunction)) { print_c_string ("#'", printcharfun); - print_object (XCAR (XCDR (obj)), printcharfun, escapeflag); + obj = XCAR (XCDR (obj)); + --print_depth; /* tail recursion */ + goto print_obj; } + /* FIXME: Do we really need the new_backquote_output gating of + special syntax for comma and comma-at? There is basically no + benefit from it at all, and it would be nice to get rid of + the recursion here without additional complexity. */ else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj))) && EQ (XCAR (obj), Qbackquote)) { @@ -2374,9 +2383,9 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) new_backquote_output--; } else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj))) - && new_backquote_output && (EQ (XCAR (obj), Qcomma) - || EQ (XCAR (obj), Qcomma_at))) + || EQ (XCAR (obj), Qcomma_at)) + && new_backquote_output) { print_object (XCAR (obj), printcharfun, false); new_backquote_output--; @@ -2386,70 +2395,135 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) else { printchar ('(', printcharfun); - /* Negative values of print-length are invalid in CL. Treat them like nil, as CMUCL does. */ intmax_t print_length = (FIXNATP (Vprint_length) ? XFIXNAT (Vprint_length) : INTMAX_MAX); - Lisp_Object objtail = Qnil; - intmax_t i = 0; - FOR_EACH_TAIL_SAFE (obj) + if (print_length == 0) + print_c_string ("...)", printcharfun); + else { - if (i != 0) - { - printchar (' ', printcharfun); - - if (!NILP (Vprint_circle)) - { - /* With the print-circle feature. */ - Lisp_Object num = Fgethash (obj, Vprint_number_table, - Qnil); - if (FIXNUMP (num)) - { - print_c_string (". ", printcharfun); - print_object (obj, printcharfun, escapeflag); - goto end_of_list; - } - } - } - - if (print_length <= i) - { - print_c_string ("...", printcharfun); - goto end_of_list; - } - - i++; - print_object (XCAR (obj), printcharfun, escapeflag); - objtail = XCDR (obj); + print_stack_push ((struct print_stack_entry){ + .type = PE_list, + .u.list.last = obj, + .u.list.maxlen = print_length, + .u.list.idx = 1, + .u.list.tortoise = obj, + .u.list.n = 2, + .u.list.m = 2, + }); + /* print the car */ + obj = XCAR (obj); + goto print_obj; } + } + break; - /* OBJTAIL non-nil here means it's the end of a dotted list - or FOR_EACH_TAIL_SAFE detected a circular list. */ - if (!NILP (objtail)) - { - print_c_string (" . ", printcharfun); + case Lisp_Vectorlike: + /* First do all the vectorlike types that have a readable syntax. */ + switch (PSEUDOVECTOR_TYPE (XVECTOR (obj))) + { + case PVEC_NORMAL_VECTOR: + { + print_stack_push_vector ("[", "]", obj, 0, ASIZE (obj), + printcharfun); + goto next_obj; + } + case PVEC_RECORD: + { + print_stack_push_vector ("#s(", ")", obj, 0, PVSIZE (obj), + printcharfun); + goto next_obj; + } + case PVEC_COMPILED: + { + print_stack_push_vector ("#[", "]", obj, 0, PVSIZE (obj), + printcharfun); + goto next_obj; + } + case PVEC_CHAR_TABLE: + { + print_stack_push_vector ("#^[", "]", obj, 0, PVSIZE (obj), + printcharfun); + goto next_obj; + } + case PVEC_SUB_CHAR_TABLE: + { + /* Make each lowest sub_char_table start a new line. + Otherwise we'll make a line extremely long, which + results in slow redisplay. */ + if (XSUB_CHAR_TABLE (obj)->depth == 3) + printchar ('\n', printcharfun); + print_c_string ("#^^[", printcharfun); + int n = sprintf (buf, "%d %d", + XSUB_CHAR_TABLE (obj)->depth, + XSUB_CHAR_TABLE (obj)->min_char); + strout (buf, n, n, printcharfun); + print_stack_push_vector ("", "]", obj, + SUB_CHAR_TABLE_OFFSET, PVSIZE (obj), + printcharfun); + goto next_obj; + } + case PVEC_HASH_TABLE: + { + struct Lisp_Hash_Table *h = XHASH_TABLE (obj); + /* Implement a readable output, e.g.: + #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */ + /* Always print the size. */ + int len = sprintf (buf, "#s(hash-table size %"pD"d", + HASH_TABLE_SIZE (h)); + strout (buf, len, len, printcharfun); - if (CONSP (objtail) && NILP (Vprint_circle)) - { - int len = sprintf (buf, "#%"PRIdMAX, i >> 1); - strout (buf, len, len, printcharfun); - goto end_of_list; - } + if (!NILP (h->test.name)) + { + print_c_string (" test ", printcharfun); + print_object (h->test.name, printcharfun, escapeflag); + } - print_object (objtail, printcharfun, escapeflag); - } + if (!NILP (h->weak)) + { + print_c_string (" weakness ", printcharfun); + print_object (h->weak, printcharfun, escapeflag); + } - end_of_list: - printchar (')', printcharfun); + print_c_string (" rehash-size ", printcharfun); + print_object (Fhash_table_rehash_size (obj), + printcharfun, escapeflag); + + print_c_string (" rehash-threshold ", printcharfun); + print_object (Fhash_table_rehash_threshold (obj), + printcharfun, escapeflag); + + if (h->purecopy) + print_c_string (" purecopy t", printcharfun); + + print_c_string (" data (", printcharfun); + + ptrdiff_t size = h->count; + /* Don't print more elements than the specified maximum. */ + if (FIXNATP (Vprint_length) && XFIXNAT (Vprint_length) < size) + size = XFIXNAT (Vprint_length); + + print_stack_push ((struct print_stack_entry){ + .type = PE_hash, + .u.hash.obj = obj, + .u.hash.nobjs = size * 2, + .u.hash.idx = 0, + .u.hash.printed = 0, + .u.hash.truncated = (size < h->count), + }); + goto next_obj; + } + + default: + break; } - break; - case Lisp_Vectorlike: if (print_vectorlike (obj, printcharfun, escapeflag, buf)) break; FALLTHROUGH; + default: { int len; @@ -2464,10 +2538,160 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) print_c_string ((" Save your buffers immediately" " and please report this bug>"), printcharfun); + break; } } - print_depth--; + + next_obj: + if (prstack.sp > base_sp) + { + /* Handle a continuation on the print stack. */ + struct print_stack_entry *e = &prstack.stack[prstack.sp - 1]; + switch (e->type) + { + case PE_list: + { + /* after "(" ELEM (* " " ELEM) */ + Lisp_Object next = XCDR (e->u.list.last); + if (NILP (next)) + { + /* end of list: print ")" */ + printchar (')', printcharfun); + --prstack.sp; + --print_depth; + goto next_obj; + } + else if (CONSP (next)) + { + if (!NILP (Vprint_circle)) + { + /* With the print-circle feature. */ + Lisp_Object num = Fgethash (next, Vprint_number_table, + Qnil); + if (FIXNUMP (num)) + { + print_c_string (" . ", printcharfun); + obj = next; + e->type = PE_rbrac; + goto print_obj; + } + } + + /* list continues: print " " ELEM ... */ + + printchar (' ', printcharfun); + + /* FIXME: We wouldn't need to keep track of idx if we + count down maxlen instead, and maintain a separate + tortoise index if required. */ + if (e->u.list.idx >= e->u.list.maxlen) + { + print_c_string ("...)", printcharfun); + --prstack.sp; + --print_depth; + goto next_obj; + } + + e->u.list.last = next; + e->u.list.idx++; + e->u.list.n--; + if (e->u.list.n == 0) + { + /* Double tortoise update period and teleport it. */ + e->u.list.m <<= 1; + e->u.list.n = e->u.list.m; + e->u.list.tortoise = next; + } + else if (BASE_EQ (next, e->u.list.tortoise)) + { + /* FIXME: This #N tail index is bug-compatible with + previous implementations but actually nonsense; + see bug#55395. */ + int len = sprintf (buf, ". #%" PRIdMAX ")", + (e->u.list.idx >> 1) - 1); + strout (buf, len, len, printcharfun); + --prstack.sp; + --print_depth; + goto next_obj; + } + obj = XCAR (next); + } + else + { + /* non-nil ending: print " . " ELEM ")" */ + print_c_string (" . ", printcharfun); + obj = next; + e->type = PE_rbrac; + } + break; + } + + case PE_rbrac: + printchar (')', printcharfun); + --prstack.sp; + --print_depth; + goto next_obj; + + case PE_vector: + if (e->u.vector.idx >= e->u.vector.size) + { + if (e->u.vector.truncated) + { + if (e->u.vector.idx > 0) + printchar (' ', printcharfun); + print_c_string ("...", printcharfun); + } + print_c_string (e->u.vector.end, printcharfun); + --prstack.sp; + --print_depth; + goto next_obj; + } + if (e->u.vector.idx > 0) + printchar (' ', printcharfun); + obj = AREF (e->u.vector.obj, e->u.vector.idx); + e->u.vector.idx++; + break; + + case PE_hash: + if (e->u.hash.printed >= e->u.hash.nobjs) + { + if (e->u.hash.truncated) + { + if (e->u.hash.printed) + printchar (' ', printcharfun); + print_c_string ("...", printcharfun); + } + print_c_string ("))", printcharfun); + --prstack.sp; + --print_depth; + goto next_obj; + } + + if (e->u.hash.printed) + printchar (' ', printcharfun); + + struct Lisp_Hash_Table *h = XHASH_TABLE (e->u.hash.obj); + if ((e->u.hash.printed & 1) == 0) + { + Lisp_Object key; + ptrdiff_t idx = e->u.hash.idx; + while (BASE_EQ ((key = HASH_KEY (h, idx)), Qunbound)) + idx++; + e->u.hash.idx = idx; + obj = key; + } + else + { + obj = HASH_VALUE (h, e->u.hash.idx); + e->u.hash.idx++; + } + e->u.hash.printed++; + break; + } + goto print_obj; + } + eassert (print_depth == base_depth); } diff --git a/test/src/print-tests.el b/test/src/print-tests.el index b9b282e5809..1b28fd19ee7 100644 --- a/test/src/print-tests.el +++ b/test/src/print-tests.el @@ -468,5 +468,21 @@ otherwise, use a different charset." (should-error (prin1-to-string 'foo nil '((a . b) b))) (should-error (prin1-to-string 'foo nil '((length . 10) . b)))) +(ert-deftest print-deeply-nested () + ;; Check that we can print a deeply nested data structure correctly. + (let ((print-circle t)) + (let ((levels 10000) + (x 'a) + (prefix nil) + (suffix nil)) + (dotimes (_ levels) + (setq x (list (vector (record 'r x)))) + (push "([#s(r " prefix) + (push ")])" suffix)) + (let ((expected (concat (apply #'concat prefix) + "a" + (apply #'concat suffix)))) + (should (equal (prin1-to-string x) expected)))))) + (provide 'print-tests) ;;; print-tests.el ends here