root/src/print.c

DEFINITIONS

1. print_free_buffer
2. print_unwind
3. print_prepare
4. print_finish
5. printchar_to_stream
6. printchar
7. octalout
8. strout
9. print_string
10. print_c_string
11. write_string
12. temp_output_buffer_setup
13. print_bind_all_defaults
14. print_create_variable_mapping
15. print_bind_overrides
16. DEFUN
17. DEFUN
18. debug_output_compilation_hack
19. debug_print
20. safe_debug_print
21. debug_format
22. DEFUN
23. print_error_message
24. float_to_string
25. print
26. grow_pp_stack
27. pp_stack_push_value
28. pp_stack_push_values
29. pp_stack_empty_p
30. pp_stack_pop
31. print_preprocess
32. DEFUN
33. print_preprocess_string
34. print_check_string_charset_prop
35. print_prune_string_charset
36. data_from_funcptr
37. print_pointer
38. print_vectorlike
39. named_escape
40. grow_print_stack
41. print_stack_push
42. print_stack_push_vector
43. print_object
44. print_interval
45. init_print_once
46. syms_of_print

     1 /* Lisp object printing and output streams.
     2 
     3 Copyright (C) 1985-2023 Free Software Foundation, Inc.
     4 
     5 This file is part of GNU Emacs.
     6 
     7 GNU Emacs is free software: you can redistribute it and/or modify
     8 it under the terms of the GNU General Public License as published by
     9 the Free Software Foundation, either version 3 of the License, or (at
    10 your option) any later version.
    11 
    12 GNU Emacs is distributed in the hope that it will be useful,
    13 but WITHOUT ANY WARRANTY; without even the implied warranty of
    14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    15 GNU General Public License for more details.
    16 
    17 You should have received a copy of the GNU General Public License
    18 along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.  */
    19 
    20 
    21 #include <config.h>
    22 #include "sysstdio.h"
    23 
    24 #include "lisp.h"
    25 #include "character.h"
    26 #include "coding.h"
    27 #include "buffer.h"
    28 #include "charset.h"
    29 #include "frame.h"
    30 #include "process.h"
    31 #include "disptab.h"
    32 #include "intervals.h"
    33 #include "blockinput.h"
    34 #include "xwidget.h"
    35 #include "dynlib.h"
    36 
    37 #include <c-ctype.h>
    38 #include <float.h>
    39 #include <ftoastr.h>
    40 #include <math.h>
    41 
    42 #if IEEE_FLOATING_POINT
    43 # include <ieee754.h>
    44 #endif
    45 
    46 #ifdef WINDOWSNT
    47 # include <sys/socket.h> /* for F_DUPFD_CLOEXEC */
    48 #endif
    49 
    50 #ifdef HAVE_TREE_SITTER
    51 #include "treesit.h"
    52 #endif
    53 
    54 struct terminal;
    55 
    56 /* Avoid actual stack overflow in print.  */
    57 static ptrdiff_t print_depth;
    58 
    59 /* Level of nesting inside outputting backquote in new style.  */
    60 static ptrdiff_t new_backquote_output;
    61 
    62 /* Detect most circularities to print finite output.  */
    63 #define PRINT_CIRCLE 200
    64 static Lisp_Object being_printed[PRINT_CIRCLE];
    65 
    66 /* Last char printed to stdout by printchar.  */
    67 static unsigned int printchar_stdout_last;
    68 
    69 struct print_buffer
    70 {
    71   char *buffer;                 /* Allocated buffer.  */
    72   ptrdiff_t size;               /* Size of allocated buffer.  */
    73   ptrdiff_t pos;                /* Chars stored in buffer.  */
    74   ptrdiff_t pos_byte;           /* Bytes stored in buffer.  */
    75 };
    76 
    77 /* When printing into a buffer, first we put the text in this
    78    block, then insert it all at once.  */
    79 static struct print_buffer print_buffer;
    80 
    81 /* Vprint_number_table is a table, that keeps objects that are going to
    82    be printed, to allow use of #n= and #n# to express sharing.
    83    For any given object, the table can give the following values:
    84      t    the object will be printed only once.
    85      -N   the object will be printed several times and will take number N.
    86      N    the object has been printed so we can refer to it as #N#.
    87    print_number_index holds the largest N already used.
    88    N has to be strictly larger than 0 since we need to distinguish -N.  */
    89 static ptrdiff_t print_number_index;
    90 static void print_interval (INTERVAL interval, Lisp_Object printcharfun);
    91 
    92 /* GDB resets this to zero on W32 to disable OutputDebugString calls.  */
    93 bool print_output_debug_flag EXTERNALLY_VISIBLE = 1;
    94 
    95 
    96 /* Low level output routines for characters and strings.  */
    97 
    98 /* This is used to free the print buffer; we don't simply record xfree
    99    since print_buffer can be reallocated during the printing.  */
   100 static void
   101 print_free_buffer (void)
   102 {
   103   xfree (print_buffer.buffer);
   104   print_buffer.buffer = NULL;
   105 }
   106 
   107 /* This is used to restore the saved contents of print_buffer
   108    when there is a recursive call to print.  */
   109 static void
   110 print_unwind (Lisp_Object saved_text)
   111 {
   112   memcpy (print_buffer.buffer, SDATA (saved_text), SCHARS (saved_text));
   113 }
   114 
   115 /* Lisp functions to do output using a stream must start with a call to
   116    print_prepare, and end with calling print_finish.
   117    Use printchar to output one character, or call strout to output a
   118    block of characters.  */
   119 
   120 /* State carried between print_prepare and print_finish.  */
   121 struct print_context
   122 {
   123   Lisp_Object printcharfun;
   124   Lisp_Object old_printcharfun;
   125   ptrdiff_t old_point, start_point;
   126   ptrdiff_t old_point_byte, start_point_byte;
   127   specpdl_ref specpdl_count;
   128 };
   129 
   130 static inline struct print_context
   131 print_prepare (Lisp_Object printcharfun)
   132 {
   133   struct print_context pc = {
   134     .old_printcharfun = printcharfun,
   135     .old_point = -1,
   136     .start_point = -1,
   137     .old_point_byte = -1,
   138     .start_point_byte = -1,
   139     .specpdl_count = SPECPDL_INDEX (),
   140   };
   141   bool multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters));
   142   record_unwind_current_buffer ();
   143   specbind(Qprint__unreadable_callback_buffer, Fcurrent_buffer ());
   144   if (NILP (printcharfun))
   145     printcharfun = Qt;
   146   if (BUFFERP (printcharfun))
   147     {
   148       if (XBUFFER (printcharfun) != current_buffer)
   149         Fset_buffer (printcharfun);
   150       printcharfun = Qnil;
   151     }
   152   if (MARKERP (printcharfun))
   153     {
   154       if (! XMARKER (printcharfun)->buffer)
   155         error ("Marker does not point anywhere");
   156       if (XMARKER (printcharfun)->buffer != current_buffer)
   157         set_buffer_internal (XMARKER (printcharfun)->buffer);
   158       ptrdiff_t marker_pos = marker_position (printcharfun);
   159       if (marker_pos < BEGV || marker_pos > ZV)
   160         signal_error ("Marker is outside the accessible part of the buffer",
   161                       printcharfun);
   162       pc.old_point = PT;
   163       pc.old_point_byte = PT_BYTE;
   164       SET_PT_BOTH (marker_pos, marker_byte_position (printcharfun));
   165       pc.start_point = PT;
   166       pc.start_point_byte = PT_BYTE;
   167       printcharfun = Qnil;
   168     }
   169   if (NILP (printcharfun))
   170     {
   171       if (NILP (BVAR (current_buffer, enable_multibyte_characters))
   172           && ! print_escape_multibyte)
   173         specbind (Qprint_escape_multibyte, Qt);
   174       if (! NILP (BVAR (current_buffer, enable_multibyte_characters))
   175           && ! print_escape_nonascii)
   176         specbind (Qprint_escape_nonascii, Qt);
   177       if (print_buffer.buffer != NULL)
   178         {
   179           Lisp_Object string = make_string_from_bytes (print_buffer.buffer,
   180                                                        print_buffer.pos,
   181                                                        print_buffer.pos_byte);
   182           record_unwind_protect (print_unwind, string);
   183         }
   184       else
   185         {
   186           int new_size = 1000;
   187           print_buffer.buffer = xmalloc (new_size);
   188           print_buffer.size = new_size;
   189           record_unwind_protect_void (print_free_buffer);
   190         }
   191       print_buffer.pos = 0;
   192       print_buffer.pos_byte = 0;
   193     }
   194   if (EQ (printcharfun, Qt) && ! noninteractive)
   195     setup_echo_area_for_printing (multibyte);
   196   pc.printcharfun = printcharfun;
   197   return pc;
   198 }
   199 
   200 static inline void
   201 print_finish (struct print_context *pc)
   202 {
   203   if (NILP (pc->printcharfun))
   204     {
   205       if (print_buffer.pos != print_buffer.pos_byte
   206           && NILP (BVAR (current_buffer, enable_multibyte_characters)))
   207         {
   208           USE_SAFE_ALLOCA;
   209           unsigned char *temp = SAFE_ALLOCA (print_buffer.pos + 1);
   210           copy_text ((unsigned char *) print_buffer.buffer, temp,
   211                      print_buffer.pos_byte, 1, 0);
   212           insert_1_both ((char *) temp, print_buffer.pos,
   213                          print_buffer.pos, 0, 1, 0);
   214           SAFE_FREE ();
   215         }
   216       else
   217         insert_1_both (print_buffer.buffer, print_buffer.pos,
   218                        print_buffer.pos_byte, 0, 1, 0);
   219       signal_after_change (PT - print_buffer.pos, 0, print_buffer.pos);
   220     }
   221   if (MARKERP (pc->old_printcharfun))
   222     set_marker_both (pc->old_printcharfun, Qnil, PT, PT_BYTE);
   223   if (pc->old_point >= 0)
   224     SET_PT_BOTH (pc->old_point
   225                  + (pc->old_point >= pc->start_point
   226                     ? PT - pc->start_point : 0),
   227                  pc->old_point_byte
   228                  + (pc->old_point_byte >= pc->start_point_byte
   229                     ? PT_BYTE - pc->start_point_byte : 0));
   230   unbind_to (pc->specpdl_count, Qnil);
   231 }
   232 
   233 /* Print character CH to the stdio stream STREAM.  */
   234 
   235 static void
   236 printchar_to_stream (unsigned int ch, FILE *stream)
   237 {
   238   Lisp_Object dv UNINIT;
   239   ptrdiff_t i = 0, n = 1;
   240   Lisp_Object coding_system = Vlocale_coding_system;
   241   bool encode_p = false;
   242 
   243   if (!NILP (Vcoding_system_for_write))
   244     coding_system = Vcoding_system_for_write;
   245   if (!NILP (coding_system))
   246     encode_p = true;
   247 
   248   if (CHAR_VALID_P (ch) && DISP_TABLE_P (Vstandard_display_table))
   249     {
   250       dv = DISP_CHAR_VECTOR (XCHAR_TABLE (Vstandard_display_table), ch);
   251       if (VECTORP (dv))
   252         {
   253           n = ASIZE (dv);
   254           goto next_char;
   255         }
   256     }
   257 
   258   while (true)
   259     {
   260       if (ASCII_CHAR_P (ch))
   261         {
   262           putc (ch, stream);
   263 #ifdef WINDOWSNT
   264           /* Send the output to a debugger (nothing happens if there
   265              isn't one).  */
   266           if (print_output_debug_flag && stream == stderr)
   267             OutputDebugString ((char []) {ch, '\0'});
   268 #endif
   269         }
   270       else
   271         {
   272           unsigned char mbstr[MAX_MULTIBYTE_LENGTH];
   273           int len = CHAR_STRING (ch, mbstr);
   274           Lisp_Object encoded_ch =
   275             make_multibyte_string ((char *) mbstr, 1, len);
   276 
   277           if (encode_p)
   278             encoded_ch = code_convert_string_norecord (encoded_ch,
   279                                                        coding_system, true);
   280           fwrite (SSDATA (encoded_ch), 1, SBYTES (encoded_ch), stream);
   281 #ifdef WINDOWSNT
   282           if (print_output_debug_flag && stream == stderr)
   283             OutputDebugString (SSDATA (encoded_ch));
   284 #endif
   285         }
   286 
   287       i++;
   288 
   289     next_char:
   290       for (; i < n; i++)
   291         if (CHARACTERP (AREF (dv, i)))
   292           break;
   293       if (! (i < n))
   294         break;
   295       ch = XFIXNAT (AREF (dv, i));
   296     }
   297 }
   298 
   299 /* Print character CH using method FUN.  FUN nil means print to
   300    print_buffer.  FUN t means print to echo area or stdout if
   301    non-interactive.  If FUN is neither nil nor t, call FUN with CH as
   302    argument.  */
   303 
   304 static void
   305 printchar (unsigned int ch, Lisp_Object fun)
   306 {
   307   if (!NILP (fun) && !EQ (fun, Qt))
   308     call1 (fun, make_fixnum (ch));
   309   else
   310     {
   311       unsigned char str[MAX_MULTIBYTE_LENGTH];
   312       int len = CHAR_STRING (ch, str);
   313 
   314       maybe_quit ();
   315 
   316       if (NILP (fun))
   317         {
   318           ptrdiff_t incr = len - (print_buffer.size - print_buffer.pos_byte);
   319           if (incr > 0)
   320             print_buffer.buffer = xpalloc (print_buffer.buffer,
   321                                            &print_buffer.size,
   322                                            incr, -1, 1);
   323           memcpy (print_buffer.buffer + print_buffer.pos_byte, str, len);
   324           print_buffer.pos += 1;
   325           print_buffer.pos_byte += len;
   326         }
   327       else if (noninteractive)
   328         {
   329           printchar_stdout_last = ch;
   330           if (DISP_TABLE_P (Vstandard_display_table))
   331             printchar_to_stream (ch, stdout);
   332           else
   333             fwrite (str, 1, len, stdout);
   334           noninteractive_need_newline = 1;
   335         }
   336       else
   337         {
   338           bool multibyte_p
   339             = !NILP (BVAR (current_buffer, enable_multibyte_characters));
   340 
   341           setup_echo_area_for_printing (multibyte_p);
   342           insert_char (ch);
   343           message_dolog ((char *) str, len, 0, multibyte_p);
   344         }
   345     }
   346 }
   347 
   348 /* Output an octal escape for C.  If C is less than '\100' consult the
   349    following character (if any) to see whether to use three octal
   350    digits to avoid misinterpretation of the next character.  The next
   351    character after C will be taken from DATA, starting at byte
   352    location I, if I is less than SIZE.  Use PRINTCHARFUN to output
   353    each character.  */
   354 
   355 static void
   356 octalout (unsigned char c, unsigned char *data, ptrdiff_t i, ptrdiff_t size,
   357           Lisp_Object printcharfun)
   358 {
   359   int digits = (c > '\77' || (i < size && '0' <= data[i] && data[i] <= '7')
   360                 ? 3
   361                 : c > '\7' ? 2 : 1);
   362   printchar ('\\', printcharfun);
   363   do
   364     printchar ('0' + ((c >> (3 * --digits)) & 7), printcharfun);
   365   while (digits != 0);
   366 }
   367 
   368 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
   369    method PRINTCHARFUN.  PRINTCHARFUN nil means output to
   370    print_buffer.  PRINTCHARFUN t means output to the echo area or to
   371    stdout if non-interactive.  If neither nil nor t, call Lisp
   372    function PRINTCHARFUN for each character printed.  MULTIBYTE
   373    non-zero means PTR contains multibyte characters.
   374 
   375    In the case where PRINTCHARFUN is nil, it is safe for PTR to point
   376    to data in a Lisp string.  Otherwise that is not safe.  */
   377 
   378 static void
   379 strout (const char *ptr, ptrdiff_t size, ptrdiff_t size_byte,
   380         Lisp_Object printcharfun)
   381 {
   382   if (NILP (printcharfun))
   383     {
   384       ptrdiff_t incr = size_byte - (print_buffer.size - print_buffer.pos_byte);
   385       if (incr > 0)
   386         print_buffer.buffer = xpalloc (print_buffer.buffer,
   387                                        &print_buffer.size, incr, -1, 1);
   388       memcpy (print_buffer.buffer + print_buffer.pos_byte, ptr, size_byte);
   389       print_buffer.pos += size;
   390       print_buffer.pos_byte += size_byte;
   391     }
   392   else if (noninteractive && EQ (printcharfun, Qt))
   393     {
   394       if (DISP_TABLE_P (Vstandard_display_table))
   395         {
   396           int len;
   397           for (ptrdiff_t i = 0; i < size_byte; i += len)
   398             {
   399               int ch = string_char_and_length ((const unsigned char *) ptr + i,
   400                                                &len);
   401               printchar_to_stream (ch, stdout);
   402             }
   403         }
   404       else
   405         fwrite (ptr, 1, size_byte, stdout);
   406 
   407       noninteractive_need_newline = 1;
   408     }
   409   else if (EQ (printcharfun, Qt))
   410     {
   411       /* Output to echo area.  We're trying to avoid a little overhead
   412          here, that's the reason we don't call printchar to do the
   413          job.  */
   414       int i;
   415       bool multibyte_p
   416         = !NILP (BVAR (current_buffer, enable_multibyte_characters));
   417 
   418       setup_echo_area_for_printing (multibyte_p);
   419       message_dolog (ptr, size_byte, 0, multibyte_p);
   420 
   421       if (size == size_byte)
   422         {
   423           for (i = 0; i < size; ++i)
   424             insert_char ((unsigned char) *ptr++);
   425         }
   426       else
   427         {
   428           int len;
   429           for (i = 0; i < size_byte; i += len)
   430             {
   431               int ch = string_char_and_length ((const unsigned char *) ptr + i,
   432                                                &len);
   433               insert_char (ch);
   434             }
   435         }
   436     }
   437   else
   438     {
   439       /* PRINTCHARFUN is a Lisp function.  */
   440       ptrdiff_t i = 0;
   441 
   442       if (size == size_byte)
   443         {
   444           while (i < size_byte)
   445             {
   446               int ch = ptr[i++];
   447               printchar (ch, printcharfun);
   448             }
   449         }
   450       else
   451         {
   452           while (i < size_byte)
   453             {
   454               /* Here, we must convert each multi-byte form to the
   455                  corresponding character code before handing it to
   456                  PRINTCHAR.  */
   457               int len, ch = (string_char_and_length
   458                              ((const unsigned char *) ptr + i, &len));
   459               printchar (ch, printcharfun);
   460               i += len;
   461             }
   462         }
   463     }
   464 }
   465 
   466 /* Print the contents of a string STRING using PRINTCHARFUN.
   467    It isn't safe to use strout in many cases,
   468    because printing one char can relocate.  */
   469 
   470 static void
   471 print_string (Lisp_Object string, Lisp_Object printcharfun)
   472 {
   473   if (EQ (printcharfun, Qt) || NILP (printcharfun))
   474     {
   475       ptrdiff_t chars;
   476 
   477       if (print_escape_nonascii)
   478         string = string_escape_byte8 (string);
   479 
   480       if (STRING_MULTIBYTE (string))
   481         chars = SCHARS (string);
   482       else if (! print_escape_nonascii
   483                && (EQ (printcharfun, Qt)
   484                    ? ! NILP (BVAR (&buffer_defaults, enable_multibyte_characters))
   485                    : ! NILP (BVAR (current_buffer, enable_multibyte_characters))))
   486         {
   487           /* If unibyte string STRING contains 8-bit codes, we must
   488              convert STRING to a multibyte string containing the same
   489              character codes.  */
   490           Lisp_Object newstr;
   491           ptrdiff_t bytes;
   492 
   493           chars = SBYTES (string);
   494           bytes = count_size_as_multibyte (SDATA (string), chars);
   495           if (chars < bytes)
   496             {
   497               newstr = make_uninit_multibyte_string (chars, bytes);
   498               str_to_multibyte (SDATA (newstr), SDATA (string), chars);
   499               string = newstr;
   500             }
   501         }
   502       else
   503         chars = SBYTES (string);
   504 
   505       if (EQ (printcharfun, Qt))
   506         {
   507           /* Output to echo area.  */
   508           ptrdiff_t nbytes = SBYTES (string);
   509 
   510           /* Copy the string contents so that relocation of STRING by
   511              GC does not cause trouble.  */
   512           USE_SAFE_ALLOCA;
   513           char *buffer = SAFE_ALLOCA (nbytes);
   514           memcpy (buffer, SDATA (string), nbytes);
   515 
   516           strout (buffer, chars, nbytes, printcharfun);
   517 
   518           SAFE_FREE ();
   519         }
   520       else
   521         /* No need to copy, since output to print_buffer can't GC.  */
   522         strout (SSDATA (string), chars, SBYTES (string), printcharfun);
   523     }
   524   else
   525     {
   526       /* Otherwise, string may be relocated by printing one char.
   527          So re-fetch the string address for each character.  */
   528       ptrdiff_t i;
   529       ptrdiff_t size = SCHARS (string);
   530       ptrdiff_t size_byte = SBYTES (string);
   531       if (size == size_byte)
   532         for (i = 0; i < size; i++)
   533           printchar (SREF (string, i), printcharfun);
   534       else
   535         for (i = 0; i < size_byte; )
   536           {
   537             /* Here, we must convert each multi-byte form to the
   538                corresponding character code before handing it to PRINTCHAR.  */
   539             int len, ch = string_char_and_length (SDATA (string) + i, &len);
   540             printchar (ch, printcharfun);
   541             i += len;
   542           }
   543     }
   544 }
   545 
   546 DEFUN ("write-char", Fwrite_char, Swrite_char, 1, 2, 0,
   547        doc: /* Output character CHARACTER to stream PRINTCHARFUN.
   548 PRINTCHARFUN defaults to the value of `standard-output' (which see).  */)
   549   (Lisp_Object character, Lisp_Object printcharfun)
   550 {
   551   if (NILP (printcharfun))
   552     printcharfun = Vstandard_output;
   553   CHECK_FIXNUM (character);
   554   struct print_context pc = print_prepare (printcharfun);
   555   printchar (XFIXNUM (character), pc.printcharfun);
   556   print_finish (&pc);
   557   return character;
   558 }
   559 
   560 /* Print the contents of a unibyte C string STRING using PRINTCHARFUN.
   561    The caller should arrange to put this inside print_prepare and print_finish.
   562    Do not use this on the contents of a Lisp string.  */
   563 
   564 static void
   565 print_c_string (char const *string, Lisp_Object printcharfun)
   566 {
   567   ptrdiff_t len = strlen (string);
   568   strout (string, len, len, printcharfun);
   569 }
   570 
   571 /* Print unibyte C string at DATA on a specified stream PRINTCHARFUN.
   572    Do not use this on the contents of a Lisp string.  */
   573 
   574 static void
   575 write_string (const char *data, Lisp_Object printcharfun)
   576 {
   577   struct print_context pc = print_prepare (printcharfun);
   578   print_c_string (data, pc.printcharfun);
   579   print_finish (&pc);
   580 }
   581 
   582 
   583 void
   584 temp_output_buffer_setup (const char *bufname)
   585 {
   586   specpdl_ref count = SPECPDL_INDEX ();
   587   register struct buffer *old = current_buffer;
   588   register Lisp_Object buf;
   589 
   590   record_unwind_current_buffer ();
   591 
   592   Fset_buffer (Fget_buffer_create (build_string (bufname), Qnil));
   593 
   594   Fkill_all_local_variables (Qnil);
   595   delete_all_overlays (current_buffer);
   596   bset_directory (current_buffer, BVAR (old, directory));
   597   bset_read_only (current_buffer, Qnil);
   598   bset_filename (current_buffer, Qnil);
   599   bset_undo_list (current_buffer, Qt);
   600   eassert (current_buffer->overlays == NULL);
   601   bset_enable_multibyte_characters
   602     (current_buffer, BVAR (&buffer_defaults, enable_multibyte_characters));
   603   specbind (Qinhibit_read_only, Qt);
   604   specbind (Qinhibit_modification_hooks, Qt);
   605   Ferase_buffer ();
   606   XSETBUFFER (buf, current_buffer);
   607 
   608   run_hook (Qtemp_buffer_setup_hook);
   609 
   610   unbind_to (count, Qnil);
   611 
   612   specbind (Qstandard_output, buf);
   613 }
   614 
   615 static void print (Lisp_Object, Lisp_Object, bool);
   616 static void print_preprocess (Lisp_Object);
   617 static void print_preprocess_string (INTERVAL, void *);
   618 static void print_object (Lisp_Object, Lisp_Object, bool);
   619 
   620 DEFUN ("terpri", Fterpri, Sterpri, 0, 2, 0,
   621        doc: /* Output a newline to stream PRINTCHARFUN.
   622 If ENSURE is non-nil only output a newline if not already at the
   623 beginning of a line.  Value is non-nil if a newline is printed.
   624 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used.  */)
   625   (Lisp_Object printcharfun, Lisp_Object ensure)
   626 {
   627   Lisp_Object val;
   628 
   629   if (NILP (printcharfun))
   630     printcharfun = Vstandard_output;
   631   struct print_context pc = print_prepare (printcharfun);
   632 
   633   if (NILP (ensure))
   634     val = Qt;
   635   /* Difficult to check if at line beginning so abort.  */
   636   else if (FUNCTIONP (pc.printcharfun))
   637     signal_error ("Unsupported function argument", pc.printcharfun);
   638   else if (noninteractive && !NILP (pc.printcharfun))
   639     val = printchar_stdout_last == 10 ? Qnil : Qt;
   640   else
   641     val = NILP (Fbolp ()) ? Qt : Qnil;
   642 
   643   if (!NILP (val))
   644     printchar ('\n', pc.printcharfun);
   645   print_finish (&pc);
   646   return val;
   647 }
   648 
   649 static Lisp_Object Vprint_variable_mapping;
   650 
   651 static void
   652 print_bind_all_defaults (void)
   653 {
   654   for (Lisp_Object vars = Vprint_variable_mapping; !NILP (vars);
   655        vars = XCDR (vars))
   656     {
   657       Lisp_Object elem = XCDR (XCAR (vars));
   658       specbind (XCAR (elem), XCAR (XCDR (elem)));
   659     }
   660 }
   661 
   662 static void
   663 print_create_variable_mapping (void)
   664 {
   665   Lisp_Object total[] = {
   666     list3 (intern ("length"), intern ("print-length"), Qnil),
   667     list3 (intern ("level"), intern ("print-level"), Qnil),
   668     list3 (intern ("circle"), intern ("print-circle"), Qnil),
   669     list3 (intern ("quoted"), intern ("print-quoted"), Qt),
   670     list3 (intern ("escape-newlines"), intern ("print-escape-newlines"), Qnil),
   671     list3 (intern ("escape-control-characters"),
   672            intern ("print-escape-control-characters"), Qnil),
   673     list3 (intern ("escape-nonascii"), intern ("print-escape-nonascii"), Qnil),
   674     list3 (intern ("escape-multibyte"),
   675            intern ("print-escape-multibyte"), Qnil),
   676     list3 (intern ("charset-text-property"),
   677            intern ("print-charset-text-property"), Qnil),
   678     list3 (intern ("unreadeable-function"),
   679            intern ("print-unreadable-function"), Qnil),
   680     list3 (intern ("gensym"), intern ("print-gensym"), Qnil),
   681     list3 (intern ("continuous-numbering"),
   682            intern ("print-continuous-numbering"), Qnil),
   683     list3 (intern ("number-table"), intern ("print-number-table"), Qnil),
   684     list3 (intern ("float-format"), intern ("float-output-format"), Qnil),
   685     list3 (intern ("integers-as-characters"),
   686            intern ("print-integers-as-characters"), Qnil),
   687   };
   688 
   689   Vprint_variable_mapping = CALLMANY (Flist, total);
   690 }
   691 
   692 static void
   693 print_bind_overrides (Lisp_Object overrides)
   694 {
   695   if (NILP (Vprint_variable_mapping))
   696     print_create_variable_mapping ();
   697 
   698   if (EQ (overrides, Qt))
   699     print_bind_all_defaults ();
   700   else if (!CONSP (overrides))
   701     xsignal (Qwrong_type_argument, Qconsp);
   702   else
   703     {
   704       while (!NILP (overrides))
   705         {
   706           Lisp_Object setting = XCAR (overrides);
   707           if (EQ (setting, Qt))
   708             print_bind_all_defaults ();
   709           else if (!CONSP (setting))
   710             xsignal (Qwrong_type_argument, Qconsp);
   711           else
   712             {
   713               Lisp_Object key = XCAR (setting),
   714                 value = XCDR (setting);
   715               Lisp_Object map = Fassq (key, Vprint_variable_mapping);
   716               if (NILP (map))
   717                 xsignal2 (Qwrong_type_argument, Qsymbolp, map);
   718               specbind (XCAR (XCDR (map)), value);
   719             }
   720 
   721           if (!NILP (XCDR (overrides)) && !CONSP (XCDR (overrides)))
   722             xsignal (Qwrong_type_argument, Qconsp);
   723           overrides = XCDR (overrides);
   724         }
   725     }
   726 }
   727 
   728 DEFUN ("prin1", Fprin1, Sprin1, 1, 3, 0,
   729        doc: /* Output the printed representation of OBJECT, any Lisp object.
   730 Quoting characters are printed when needed to make output that `read'
   731 can handle, whenever this is possible.  For complex objects, the behavior
   732 is controlled by `print-level' and `print-length', which see.
   733 
   734 OBJECT is any of the Lisp data types: a number, a string, a symbol,
   735 a list, a buffer, a window, a frame, etc.
   736 
   737 A printed representation of an object is text which describes that object.
   738 
   739 Optional argument PRINTCHARFUN is the output stream, which can be one
   740 of these:
   741 
   742    - a buffer, in which case output is inserted into that buffer at point;
   743    - a marker, in which case output is inserted at marker's position;
   744    - a function, in which case that function is called once for each
   745      character of OBJECT's printed representation;
   746    - a symbol, in which case that symbol's function definition is called; or
   747    - t, in which case the output is displayed in the echo area.
   748 
   749 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
   750 is used instead.
   751 
   752 Optional argument OVERRIDES should be a list of settings for print-related
   753 variables.  An element in this list can be the symbol t, which means "reset
   754 all the values to their defaults".  Otherwise, an element should be a pair,
   755 where the `car' or the pair is the setting symbol, and the `cdr' is the
   756 value of the setting to use for this `prin1' call.
   757 
   758 For instance:
   759 
   760   (prin1 object nil \\='((length . 100) (circle . t))).
   761 
   762 See Info node `(elisp)Output Overrides' for a list of possible values.
   763 
   764 As a special case, OVERRIDES can also simply be the symbol t, which
   765 means "use default values for all the print-related settings".  */)
   766   (Lisp_Object object, Lisp_Object printcharfun, Lisp_Object overrides)
   767 {
   768   specpdl_ref count = SPECPDL_INDEX ();
   769 
   770   if (NILP (printcharfun))
   771     printcharfun = Vstandard_output;
   772   if (!NILP (overrides))
   773     print_bind_overrides (overrides);
   774 
   775   struct print_context pc = print_prepare (printcharfun);
   776   print (object, pc.printcharfun, 1);
   777   print_finish (&pc);
   778 
   779   return unbind_to (count, object);
   780 }
   781 
   782 /* A buffer which is used to hold output being built by prin1-to-string.  */
   783 Lisp_Object Vprin1_to_string_buffer;
   784 
   785 DEFUN ("prin1-to-string", Fprin1_to_string, Sprin1_to_string, 1, 3, 0,
   786        doc: /* Return a string containing the printed representation of OBJECT.
   787 OBJECT can be any Lisp object.  This function outputs quoting characters
   788 when necessary to make output that `read' can handle, whenever possible,
   789 unless the optional second argument NOESCAPE is non-nil.  For complex objects,
   790 the behavior is controlled by `print-level' and `print-length', which see.
   791 
   792 OBJECT is any of the Lisp data types: a number, a string, a symbol,
   793 a list, a buffer, a window, a frame, etc.
   794 
   795 See `prin1' for the meaning of OVERRIDES.
   796 
   797 A printed representation of an object is text which describes that object.  */)
   798   (Lisp_Object object, Lisp_Object noescape, Lisp_Object overrides)
   799 {
   800   specpdl_ref count = SPECPDL_INDEX ();
   801 
   802   specbind (Qinhibit_modification_hooks, Qt);
   803 
   804   if (!NILP (overrides))
   805     print_bind_overrides (overrides);
   806 
   807   /* Save and restore this: we are altering a buffer
   808      but we don't want to deactivate the mark just for that.
   809      No need for specbind, since errors deactivate the mark.  */
   810   Lisp_Object save_deactivate_mark = Vdeactivate_mark;
   811 
   812   struct print_context pc = print_prepare (Vprin1_to_string_buffer);
   813   print (object, pc.printcharfun, NILP (noescape));
   814   /* Make Vprin1_to_string_buffer be the default buffer after print_finish */
   815   print_finish (&pc);
   816 
   817   struct buffer *previous = current_buffer;
   818   set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
   819   object = Fbuffer_string ();
   820   if (SBYTES (object) == SCHARS (object))
   821     STRING_SET_UNIBYTE (object);
   822 
   823   /* Note that this won't make prepare_to_modify_buffer call
   824      ask-user-about-supersession-threat because this buffer
   825      does not visit a file.  */
   826   Ferase_buffer ();
   827   set_buffer_internal (previous);
   828 
   829   Vdeactivate_mark = save_deactivate_mark;
   830 
   831   return unbind_to (count, object);
   832 }
   833 
   834 DEFUN ("princ", Fprinc, Sprinc, 1, 2, 0,
   835        doc: /* Output the printed representation of OBJECT, any Lisp object.
   836 No quoting characters are used; no delimiters are printed around
   837 the contents of strings.
   838 
   839 OBJECT is any of the Lisp data types: a number, a string, a symbol,
   840 a list, a buffer, a window, a frame, etc.
   841 
   842 A printed representation of an object is text which describes that object.
   843 
   844 Optional argument PRINTCHARFUN is the output stream, which can be one
   845 of these:
   846 
   847    - a buffer, in which case output is inserted into that buffer at point;
   848    - a marker, in which case output is inserted at marker's position;
   849    - a function, in which case that function is called once for each
   850      character of OBJECT's printed representation;
   851    - a symbol, in which case that symbol's function definition is called; or
   852    - t, in which case the output is displayed in the echo area.
   853 
   854 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
   855 is used instead.  */)
   856   (Lisp_Object object, Lisp_Object printcharfun)
   857 {
   858   if (NILP (printcharfun))
   859     printcharfun = Vstandard_output;
   860   struct print_context pc = print_prepare (printcharfun);
   861   if (STRINGP (object)
   862       && !string_intervals (object)
   863       && NILP (Vprint_continuous_numbering))
   864     /* fast path for plain strings */
   865     print_string (object, pc.printcharfun);
   866   else
   867     print (object, pc.printcharfun, 0);
   868   print_finish (&pc);
   869   return object;
   870 }
   871 
   872 DEFUN ("print", Fprint, Sprint, 1, 2, 0,
   873        doc: /* Output the printed representation of OBJECT, with newlines around it.
   874 Quoting characters are printed when needed to make output that `read'
   875 can handle, whenever this is possible.  For complex objects, the behavior
   876 is controlled by `print-level' and `print-length', which see.
   877 
   878 OBJECT is any of the Lisp data types: a number, a string, a symbol,
   879 a list, a buffer, a window, a frame, etc.
   880 
   881 A printed representation of an object is text which describes that object.
   882 
   883 Optional argument PRINTCHARFUN is the output stream, which can be one
   884 of these:
   885 
   886    - a buffer, in which case output is inserted into that buffer at point;
   887    - a marker, in which case output is inserted at marker's position;
   888    - a function, in which case that function is called once for each
   889      character of OBJECT's printed representation;
   890    - a symbol, in which case that symbol's function definition is called; or
   891    - t, in which case the output is displayed in the echo area.
   892 
   893 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
   894 is used instead.  */)
   895   (Lisp_Object object, Lisp_Object printcharfun)
   896 {
   897   if (NILP (printcharfun))
   898     printcharfun = Vstandard_output;
   899   struct print_context pc = print_prepare (printcharfun);
   900   printchar ('\n', pc.printcharfun);
   901   print (object, pc.printcharfun, 1);
   902   printchar ('\n', pc.printcharfun);
   903   print_finish (&pc);
   904   return object;
   905 }
   906 
   907 DEFUN ("flush-standard-output", Fflush_standard_output, Sflush_standard_output,
   908        0, 0, 0,
   909        doc: /* Flush standard-output.
   910 This can be useful after using `princ' and the like in scripts.  */)
   911   (void)
   912 {
   913   fflush (stdout);
   914   return Qnil;
   915 }
   916 
   917 DEFUN ("external-debugging-output", Fexternal_debugging_output, Sexternal_debugging_output, 1, 1, 0,
   918        doc: /* Write CHARACTER to stderr.
   919 You can call `print' while debugging emacs, and pass it this function
   920 to make it write to the debugging output.  */)
   921   (Lisp_Object character)
   922 {
   923   CHECK_FIXNUM (character);
   924   printchar_to_stream (XFIXNUM (character), stderr);
   925   return character;
   926 }
   927 
   928 /* This function is never called.  Its purpose is to prevent
   929    print_output_debug_flag from being optimized away.  */
   930 
   931 extern void debug_output_compilation_hack (bool) EXTERNALLY_VISIBLE;
   932 void
   933 debug_output_compilation_hack (bool x)
   934 {
   935   print_output_debug_flag = x;
   936 }
   937 
   938 DEFUN ("redirect-debugging-output", Fredirect_debugging_output, Sredirect_debugging_output,
   939        1, 2,
   940        "FDebug output file: \nP",
   941        doc: /* Redirect debugging output (stderr stream) to file FILE.
   942 If FILE is nil, reset target to the initial stderr stream.
   943 Optional arg APPEND non-nil (interactively, with prefix arg) means
   944 append to existing target file.  */)
   945   (Lisp_Object file, Lisp_Object append)
   946 {
   947   /* If equal to STDERR_FILENO, stderr has not been duplicated and is OK as-is.
   948      Otherwise, this is a close-on-exec duplicate of the original stderr. */
   949   static int stderr_dup = STDERR_FILENO;
   950   int fd = stderr_dup;
   951 
   952   if (! NILP (file))
   953     {
   954       file = Fexpand_file_name (file, Qnil);
   955 
   956       if (stderr_dup == STDERR_FILENO)
   957         {
   958           int n = fcntl (STDERR_FILENO, F_DUPFD_CLOEXEC, STDERR_FILENO + 1);
   959           if (n < 0)
   960             report_file_error ("dup", file);
   961           stderr_dup = n;
   962         }
   963 
   964       fd = emacs_open (SSDATA (ENCODE_FILE (file)),
   965                        (O_WRONLY | O_CREAT
   966                         | (! NILP (append) ? O_APPEND : O_TRUNC)),
   967                        0666);
   968       if (fd < 0)
   969         report_file_error ("Cannot open debugging output stream", file);
   970     }
   971 
   972   fflush (stderr);
   973   if (dup2 (fd, STDERR_FILENO) < 0)
   974     report_file_error ("dup2", file);
   975   if (fd != stderr_dup)
   976     emacs_close (fd);
   977   return Qnil;
   978 }
   979 
   980 
   981 /* This is the interface for debugging printing.  */
   982 
   983 void
   984 debug_print (Lisp_Object arg)
   985 {
   986   Fprin1 (arg, Qexternal_debugging_output, Qnil);
   987   fputs ("\r\n", stderr);
   988 }
   989 
   990 void safe_debug_print (Lisp_Object) EXTERNALLY_VISIBLE;
   991 void
   992 safe_debug_print (Lisp_Object arg)
   993 {
   994   int valid = valid_lisp_object_p (arg);
   995 
   996   if (valid > 0)
   997     debug_print (arg);
   998   else
   999     {
  1000       EMACS_UINT n = XLI (arg);
  1001       fprintf (stderr, "#<%s_LISP_OBJECT 0x%08"pI"x>\r\n",
  1002                !valid ? "INVALID" : "SOME",
  1003                n);
  1004     }
  1005 }
  1006 
  1007 /* This function formats the given object and returns the result as a
  1008    string. Use this in contexts where you can inspect strings, but
  1009    where stderr output won't work --- e.g., while replaying rr
  1010    recordings.  */
  1011 const char * debug_format (const char *, Lisp_Object) EXTERNALLY_VISIBLE;
  1012 const char *
  1013 debug_format (const char *fmt, Lisp_Object arg)
  1014 {
  1015   return SSDATA (CALLN (Fformat, build_string (fmt), arg));
  1016 }
  1017 
  1018 
  1019 DEFUN ("error-message-string", Ferror_message_string, Serror_message_string,
  1020        1, 1, 0,
  1021        doc: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
  1022 See Info anchor `(elisp)Definition of signal' for some details on how this
  1023 error message is constructed.  */)
  1024   (Lisp_Object obj)
  1025 {
  1026   struct buffer *old = current_buffer;
  1027   Lisp_Object value;
  1028 
  1029   /* If OBJ is (error STRING), just return STRING.
  1030      That is not only faster, it also avoids the need to allocate
  1031      space here when the error is due to memory full.  */
  1032   if (CONSP (obj) && EQ (XCAR (obj), Qerror)
  1033       && CONSP (XCDR (obj))
  1034       && STRINGP (XCAR (XCDR (obj)))
  1035       && NILP (XCDR (XCDR (obj))))
  1036     return XCAR (XCDR (obj));
  1037 
  1038   print_error_message (obj, Vprin1_to_string_buffer, 0, Qnil);
  1039 
  1040   set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
  1041   value = Fbuffer_string ();
  1042 
  1043   Ferase_buffer ();
  1044   set_buffer_internal (old);
  1045 
  1046   return value;
  1047 }
  1048 
  1049 /* Print an error message for the error DATA onto Lisp output stream
  1050    STREAM (suitable for the print functions).
  1051    CONTEXT is a C string describing the context of the error.
  1052    CALLER is the Lisp function inside which the error was signaled.  */
  1053 
  1054 void
  1055 print_error_message (Lisp_Object data, Lisp_Object stream, const char *context,
  1056                      Lisp_Object caller)
  1057 {
  1058   Lisp_Object errname, errmsg, file_error, tail;
  1059 
  1060   if (context != 0)
  1061     write_string (context, stream);
  1062 
  1063   /* If we know from where the error was signaled, show it in
  1064    *Messages*.  */
  1065   if (!NILP (caller) && SYMBOLP (caller))
  1066     {
  1067       Lisp_Object cname = SYMBOL_NAME (caller);
  1068       ptrdiff_t cnamelen = SBYTES (cname);
  1069       USE_SAFE_ALLOCA;
  1070       char *name = SAFE_ALLOCA (cnamelen);
  1071       memcpy (name, SDATA (cname), cnamelen);
  1072       message_dolog (name, cnamelen, 0, STRING_MULTIBYTE (cname));
  1073       message_dolog (": ", 2, 0, 0);
  1074       SAFE_FREE ();
  1075     }
  1076 
  1077   errname = Fcar (data);
  1078 
  1079   if (EQ (errname, Qerror))
  1080     {
  1081       data = Fcdr (data);
  1082       if (!CONSP (data))
  1083         data = Qnil;
  1084       errmsg = Fcar (data);
  1085       file_error = Qnil;
  1086     }
  1087   else
  1088     {
  1089       Lisp_Object error_conditions = Fget (errname, Qerror_conditions);
  1090       errmsg = Fget (errname, Qerror_message);
  1091       /* During loadup 'substitute-command-keys' might not be available.  */
  1092       if (!NILP (Ffboundp (Qsubstitute_command_keys)))
  1093         {
  1094           /* `substitute-command-keys' may bug out, which would lead
  1095              to infinite recursion when we're called from
  1096              skip_debugger, so ignore errors.  */
  1097           Lisp_Object subs = safe_call1 (Qsubstitute_command_keys, errmsg);
  1098           if (!NILP (subs))
  1099             errmsg = subs;
  1100         }
  1101 
  1102       file_error = Fmemq (Qfile_error, error_conditions);
  1103     }
  1104 
  1105   /* Print an error message including the data items.  */
  1106 
  1107   tail = Fcdr_safe (data);
  1108 
  1109   /* For file-error, make error message by concatenating
  1110      all the data items.  They are all strings.  */
  1111   if (!NILP (file_error) && CONSP (tail))
  1112     errmsg = XCAR (tail), tail = XCDR (tail);
  1113 
  1114   {
  1115     const char *sep = ": ";
  1116 
  1117     if (!STRINGP (errmsg))
  1118       write_string ("peculiar error", stream);
  1119     else if (SCHARS (errmsg))
  1120       Fprinc (errmsg, stream);
  1121     else
  1122       sep = NULL;
  1123 
  1124     FOR_EACH_TAIL (tail)
  1125       {
  1126         if (sep)
  1127           write_string (sep, stream);
  1128         sep = ", ";
  1129         Lisp_Object obj = XCAR (tail);
  1130         if (!NILP (file_error)
  1131             || EQ (errname, Qend_of_file) || EQ (errname, Quser_error))
  1132           Fprinc (obj, stream);
  1133         else
  1134           Fprin1 (obj, stream, Qnil);
  1135       }
  1136   }
  1137 }
  1138 
  1139 
  1140 
  1141 /*
  1142  * The buffer should be at least as large as the max string size of the
  1143  * largest float, printed in the biggest notation.  This is undoubtedly
  1144  * 20d float_output_format, with the negative of the C-constant "HUGE"
  1145  * from <math.h>.
  1146  *
  1147  * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
  1148  *
  1149  * I assume that IEEE-754 format numbers can take 329 bytes for the worst
  1150  * case of -1e307 in 20d float_output_format. What is one to do (short of
  1151  * re-writing _doprnt to be more sane)?
  1152  *                      -wsr
  1153  * Given the above, the buffer must be least FLOAT_TO_STRING_BUFSIZE bytes.
  1154  */
  1155 
  1156 int
  1157 float_to_string (char *buf, double data)
  1158 {
  1159   char *cp;
  1160   int width;
  1161   int len;
  1162 
  1163   if (isinf (data))
  1164     {
  1165       static char const minus_infinity_string[] = "-1.0e+INF";
  1166       bool positive = 0 < data;
  1167       strcpy (buf, minus_infinity_string + positive);
  1168       return sizeof minus_infinity_string - 1 - positive;
  1169     }
  1170 #if IEEE_FLOATING_POINT
  1171   if (isnan (data))
  1172     {
  1173       union ieee754_double u = { .d = data };
  1174       uintmax_t hi = u.ieee_nan.mantissa0;
  1175       return sprintf (buf, &"-%"PRIuMAX".0e+NaN"[!u.ieee_nan.negative],
  1176                       (hi << 31 << 1) + u.ieee_nan.mantissa1);
  1177     }
  1178 #endif
  1179 
  1180   if (NILP (Vfloat_output_format)
  1181       || !STRINGP (Vfloat_output_format))
  1182   lose:
  1183     {
  1184       /* Generate the fewest number of digits that represent the
  1185          floating point value without losing information.  */
  1186       len = dtoastr (buf, FLOAT_TO_STRING_BUFSIZE - 2, 0, 0, data);
  1187       /* The decimal point must be printed, or the byte compiler can
  1188          get confused (Bug#8033). */
  1189       width = 1;
  1190     }
  1191   else                  /* oink oink */
  1192     {
  1193       /* Check that the spec we have is fully valid.
  1194          This means not only valid for printf,
  1195          but meant for floats, and reasonable.  */
  1196       cp = SSDATA (Vfloat_output_format);
  1197 
  1198       if (cp[0] != '%')
  1199         goto lose;
  1200       if (cp[1] != '.')
  1201         goto lose;
  1202 
  1203       cp += 2;
  1204 
  1205       /* Check the width specification.  */
  1206       width = -1;
  1207       if ('0' <= *cp && *cp <= '9')
  1208         {
  1209           width = 0;
  1210           do
  1211             {
  1212               width = (width * 10) + (*cp++ - '0');
  1213               if (DBL_DIG < width)
  1214                 goto lose;
  1215             }
  1216           while (*cp >= '0' && *cp <= '9');
  1217 
  1218           /* A precision of zero is valid only for %f.  */
  1219           if (width == 0 && *cp != 'f')
  1220             goto lose;
  1221         }
  1222 
  1223       if (*cp != 'e' && *cp != 'f' && *cp != 'g')
  1224         goto lose;
  1225 
  1226       if (cp[1] != 0)
  1227         goto lose;
  1228 
  1229       len = sprintf (buf, SSDATA (Vfloat_output_format), data);
  1230     }
  1231 
  1232   /* Make sure there is a decimal point with digit after, or an
  1233      exponent, so that the value is readable as a float.  But don't do
  1234      this with "%.0f"; it's valid for that not to produce a decimal
  1235      point.  Note that width can be 0 only for %.0f.  */
  1236   if (width != 0)
  1237     {
  1238       for (cp = buf; *cp; cp++)
  1239         if ((*cp < '0' || *cp > '9') && *cp != '-')
  1240           break;
  1241 
  1242       if (*cp == '.' && cp[1] == 0)
  1243         {
  1244           cp[1] = '0';
  1245           cp[2] = 0;
  1246           len++;
  1247         }
  1248       else if (*cp == 0)
  1249         {
  1250           *cp++ = '.';
  1251           *cp++ = '0';
  1252           *cp++ = 0;
  1253           len += 2;
  1254         }
  1255     }
  1256 
  1257   return len;
  1258 }
  1259 
  1260 
  1261 static void
  1262 print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
  1263 {
  1264   new_backquote_output = 0;
  1265 
  1266   /* Reset print_number_index and Vprint_number_table only when
  1267      the variable Vprint_continuous_numbering is nil.  Otherwise,
  1268      the values of these variables will be kept between several
  1269      print functions.  */
  1270   if (NILP (Vprint_continuous_numbering)
  1271       || NILP (Vprint_number_table))
  1272     {
  1273       print_number_index = 0;
  1274       Vprint_number_table = Qnil;
  1275     }
  1276 
  1277   /* Construct Vprint_number_table for print-circle.  */
  1278   if (!NILP (Vprint_circle))
  1279     {
  1280       /* Construct Vprint_number_table.
  1281          This increments print_number_index for the objects added.  */
  1282       print_preprocess (obj);
  1283 
  1284       if (HASH_TABLE_P (Vprint_number_table))
  1285         { /* Remove unnecessary objects, which appear only once in OBJ;
  1286              that is, whose status is Qt.  */
  1287           struct Lisp_Hash_Table *h = XHASH_TABLE (Vprint_number_table);
  1288           ptrdiff_t i;
  1289 
  1290           for (i = 0; i < HASH_TABLE_SIZE (h); ++i)
  1291             {
  1292               Lisp_Object key =  HASH_KEY (h, i);
  1293               if (!BASE_EQ (key, Qunbound)
  1294                   && EQ (HASH_VALUE (h, i), Qt))
  1295                 Fremhash (key, Vprint_number_table);
  1296             }
  1297         }
  1298     }
  1299 
  1300   print_depth = 0;
  1301   print_object (obj, printcharfun, escapeflag);
  1302 }
  1303 
  1304 #define PRINT_CIRCLE_CANDIDATE_P(obj)                      \
  1305   (STRINGP (obj)                                           \
  1306    || CONSP (obj)                                          \
  1307    || (VECTORLIKEP (obj)                                   \
  1308        && (VECTORP (obj) || COMPILEDP (obj)                \
  1309            || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \
  1310            || HASH_TABLE_P (obj) || FONTP (obj)            \
  1311            || RECORDP (obj)))                              \
  1312    || (! NILP (Vprint_gensym)                              \
  1313        && SYMBOLP (obj)                                    \
  1314        && !SYMBOL_INTERNED_P (obj)))
  1315 
  1316 /* The print preprocess stack, used to traverse data structures.  */
  1317 
  1318 struct print_pp_entry {
  1319   ptrdiff_t n;                  /* number of values, or 0 if a single value */
  1320   union {
  1321     Lisp_Object value;          /* when n = 0 */
  1322     Lisp_Object *values;        /* when n > 0 */
  1323   } u;
  1324 };
  1325 
  1326 struct print_pp_stack {
  1327   struct print_pp_entry *stack;  /* base of stack */
  1328   ptrdiff_t size;                /* allocated size in entries */
  1329   ptrdiff_t sp;                  /* current number of entries */
  1330 };
  1331 
  1332 static struct print_pp_stack ppstack = {NULL, 0, 0};
  1333 
  1334 NO_INLINE static void
  1335 grow_pp_stack (void)
  1336 {
  1337   struct print_pp_stack *ps = &ppstack;
  1338   eassert (ps->sp == ps->size);
  1339   ps->stack = xpalloc (ps->stack, &ps->size, 1, -1, sizeof *ps->stack);
  1340   eassert (ps->sp < ps->size);
  1341 }
  1342 
  1343 static inline void
  1344 pp_stack_push_value (Lisp_Object value)
  1345 {
  1346   if (ppstack.sp >= ppstack.size)
  1347     grow_pp_stack ();
  1348   ppstack.stack[ppstack.sp++] = (struct print_pp_entry){.n = 0,
  1349                                                         .u.value = value};
  1350 }
  1351 
  1352 static inline void
  1353 pp_stack_push_values (Lisp_Object *values, ptrdiff_t n)
  1354 {
  1355   eassume (n >= 0);
  1356   if (n == 0)
  1357     return;
  1358   if (ppstack.sp >= ppstack.size)
  1359     grow_pp_stack ();
  1360   ppstack.stack[ppstack.sp++] = (struct print_pp_entry){.n = n,
  1361                                                         .u.values = values};
  1362 }
  1363 
  1364 static inline bool
  1365 pp_stack_empty_p (void)
  1366 {
  1367   return ppstack.sp <= 0;
  1368 }
  1369 
  1370 static inline Lisp_Object
  1371 pp_stack_pop (void)
  1372 {
  1373   eassume (!pp_stack_empty_p ());
  1374   struct print_pp_entry *e = &ppstack.stack[ppstack.sp - 1];
  1375   if (e->n == 0)                /* single value */
  1376     {
  1377       --ppstack.sp;
  1378       return e->u.value;
  1379     }
  1380   /* Array of values: pop them left to right, which seems to be slightly
  1381      faster than right to left.  */
  1382   e->n--;
  1383   if (e->n == 0)
  1384     --ppstack.sp;               /* last value consumed */
  1385   return (++e->u.values)[-1];
  1386 }
  1387 
  1388 /* Construct Vprint_number_table for the print-circle feature
  1389    according to the structure of OBJ.  OBJ itself and all its elements
  1390    will be added to Vprint_number_table recursively if it is a list,
  1391    vector, compiled function, char-table, string (its text properties
  1392    will be traced), or a symbol that has no obarray (this is for the
  1393    print-gensym feature).  The status fields of Vprint_number_table
  1394    mean whether each object appears more than once in OBJ: Qnil at the
  1395    first time, and Qt after that.  */
  1396 static void
  1397 print_preprocess (Lisp_Object obj)
  1398 {
  1399   eassert (!NILP (Vprint_circle));
  1400   ptrdiff_t base_sp = ppstack.sp;
  1401 
  1402   for (;;)
  1403     {
  1404       if (PRINT_CIRCLE_CANDIDATE_P (obj))
  1405         {
  1406           if (!HASH_TABLE_P (Vprint_number_table))
  1407             Vprint_number_table = CALLN (Fmake_hash_table, QCtest, Qeq);
  1408 
  1409           Lisp_Object num = Fgethash (obj, Vprint_number_table, Qnil);
  1410           if (!NILP (num)
  1411               /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
  1412                  always print the gensym with a number.  This is a special for
  1413                  the lisp function byte-compile-output-docform.  */
  1414               || (!NILP (Vprint_continuous_numbering)
  1415                   && SYMBOLP (obj)
  1416                   && !SYMBOL_INTERNED_P (obj)))
  1417             { /* OBJ appears more than once.  Let's remember that.  */
  1418               if (!FIXNUMP (num))
  1419                 {
  1420                   print_number_index++;
  1421                   /* Negative number indicates it hasn't been printed yet.  */
  1422                   Fputhash (obj, make_fixnum (- print_number_index),
  1423                             Vprint_number_table);
  1424                 }
  1425             }
  1426           else
  1427             {
  1428               /* OBJ is not yet recorded.  Let's add to the table.  */
  1429               Fputhash (obj, Qt, Vprint_number_table);
  1430 
  1431               switch (XTYPE (obj))
  1432                 {
  1433                 case Lisp_String:
  1434                   /* A string may have text properties,
  1435                      which can be circular. */
  1436                   traverse_intervals_noorder (string_intervals (obj),
  1437                                               print_preprocess_string, NULL);
  1438                   break;
  1439 
  1440                 case Lisp_Cons:
  1441                   if (!NILP (XCDR (obj)))
  1442                     pp_stack_push_value (XCDR (obj));
  1443                   obj = XCAR (obj);
  1444                   continue;
  1445 
  1446                 case Lisp_Vectorlike:
  1447                   {
  1448                     struct Lisp_Vector *vec = XVECTOR (obj);
  1449                     ptrdiff_t size = ASIZE (obj);
  1450                     if (size & PSEUDOVECTOR_FLAG)
  1451                       size &= PSEUDOVECTOR_SIZE_MASK;
  1452                     ptrdiff_t start = (SUB_CHAR_TABLE_P (obj)
  1453                                        ? SUB_CHAR_TABLE_OFFSET : 0);
  1454                     pp_stack_push_values (vec->contents + start, size - start);
  1455                     if (HASH_TABLE_P (obj))
  1456                       {
  1457                         struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
  1458                         obj = h->key_and_value;
  1459                         continue;
  1460                       }
  1461                     break;
  1462                   }
  1463 
  1464                 default:
  1465                   break;
  1466                 }
  1467             }
  1468         }
  1469 
  1470       if (ppstack.sp <= base_sp)
  1471         break;
  1472       obj = pp_stack_pop ();
  1473     }
  1474 }
  1475 
  1476 DEFUN ("print--preprocess", Fprint_preprocess, Sprint_preprocess, 1, 1, 0,
  1477        doc: /* Extract sharing info from OBJECT needed to print it.
  1478 Fills `print-number-table' if `print-circle' is non-nil.  Does nothing
  1479 if `print-circle' is nil.  */)
  1480      (Lisp_Object object)
  1481 {
  1482   if (!NILP (Vprint_circle))
  1483     {
  1484       print_number_index = 0;
  1485       print_preprocess (object);
  1486     }
  1487   return Qnil;
  1488 }
  1489 
  1490 static void
  1491 print_preprocess_string (INTERVAL interval, void *arg)
  1492 {
  1493   print_preprocess (interval->plist);
  1494 }
  1495 
  1496 static void print_check_string_charset_prop (INTERVAL interval, Lisp_Object string);
  1497 
  1498 #define PRINT_STRING_NON_CHARSET_FOUND 1
  1499 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
  1500 
  1501 /* Bitwise or of the above macros.  */
  1502 static int print_check_string_result;
  1503 
  1504 static void
  1505 print_check_string_charset_prop (INTERVAL interval, Lisp_Object string)
  1506 {
  1507   Lisp_Object val;
  1508 
  1509   if (NILP (interval->plist)
  1510       || (print_check_string_result == (PRINT_STRING_NON_CHARSET_FOUND
  1511                                         | PRINT_STRING_UNSAFE_CHARSET_FOUND)))
  1512     return;
  1513   for (val = interval->plist; CONSP (val) && ! EQ (XCAR (val), Qcharset);
  1514        val = XCDR (XCDR (val)));
  1515   if (! CONSP (val))
  1516     {
  1517       print_check_string_result |= PRINT_STRING_NON_CHARSET_FOUND;
  1518       return;
  1519     }
  1520   if (! (print_check_string_result & PRINT_STRING_NON_CHARSET_FOUND))
  1521     {
  1522       if (! EQ (val, interval->plist)
  1523           || CONSP (XCDR (XCDR (val))))
  1524         print_check_string_result |= PRINT_STRING_NON_CHARSET_FOUND;
  1525     }
  1526   if (! (print_check_string_result & PRINT_STRING_UNSAFE_CHARSET_FOUND))
  1527     {
  1528       ptrdiff_t charpos = interval->position;
  1529       ptrdiff_t bytepos = string_char_to_byte (string, charpos);
  1530       Lisp_Object charset = XCAR (XCDR (val));
  1531 
  1532       for (ptrdiff_t i = 0; i < LENGTH (interval); i++)
  1533         {
  1534           int c = fetch_string_char_advance (string, &charpos, &bytepos);
  1535           if (! ASCII_CHAR_P (c)
  1536               && ! EQ (CHARSET_NAME (CHAR_CHARSET (c)), charset))
  1537             {
  1538               print_check_string_result |= PRINT_STRING_UNSAFE_CHARSET_FOUND;
  1539               break;
  1540             }
  1541         }
  1542     }
  1543 }
  1544 
  1545 /* The value is (charset . nil).  */
  1546 static Lisp_Object print_prune_charset_plist;
  1547 
  1548 static Lisp_Object
  1549 print_prune_string_charset (Lisp_Object string)
  1550 {
  1551   print_check_string_result = 0;
  1552   traverse_intervals (string_intervals (string), 0,
  1553                       print_check_string_charset_prop, string);
  1554   if (NILP (Vprint_charset_text_property)
  1555       || ! (print_check_string_result & PRINT_STRING_UNSAFE_CHARSET_FOUND))
  1556     {
  1557       string = Fcopy_sequence (string);
  1558       if (print_check_string_result & PRINT_STRING_NON_CHARSET_FOUND)
  1559         {
  1560           if (NILP (print_prune_charset_plist))
  1561             print_prune_charset_plist = list1 (Qcharset);
  1562           Fremove_text_properties (make_fixnum (0),
  1563                                    make_fixnum (SCHARS (string)),
  1564                                    print_prune_charset_plist, string);
  1565         }
  1566       else
  1567         Fset_text_properties (make_fixnum (0), make_fixnum (SCHARS (string)),
  1568                               Qnil, string);
  1569     }
  1570   return string;
  1571 }
  1572 
  1573 #ifdef HAVE_MODULES
  1574 /* Return a data pointer equal to FUNCPTR.  */
  1575 
  1576 static void const *
  1577 data_from_funcptr (void (*funcptr) (void))
  1578 {
  1579   /* The module code, and the POSIX API for dynamic linking, already
  1580      assume that function and data pointers are represented
  1581      interchangeably, so it's OK to assume that here too.  */
  1582   return (void const *) funcptr;
  1583 }
  1584 
  1585 /* Print the value of the pointer PTR.  */
  1586 
  1587 static void
  1588 print_pointer (Lisp_Object printcharfun, char *buf, const char *prefix,
  1589                const void *ptr)
  1590 {
  1591   uintptr_t ui = (uintptr_t) ptr;
  1592 
  1593   /* In theory this assignment could lose info on pre-C99 hosts, but
  1594      in practice it doesn't.  */
  1595   uintmax_t up = ui;
  1596 
  1597   int len = sprintf (buf, "%s 0x%" PRIxMAX, prefix, up);
  1598   strout (buf, len, len, printcharfun);
  1599 }
  1600 #endif
  1601 
  1602 static bool
  1603 print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
  1604                   char *buf)
  1605 {
  1606   /* First do all the vectorlike types that have a readable syntax.  */
  1607   switch (PSEUDOVECTOR_TYPE (XVECTOR (obj)))
  1608     {
  1609     case PVEC_BIGNUM:
  1610       {
  1611         ptrdiff_t size = bignum_bufsize (obj, 10);
  1612         USE_SAFE_ALLOCA;
  1613         char *str = SAFE_ALLOCA (size);
  1614         ptrdiff_t len = bignum_to_c_string (str, size, obj, 10);
  1615         strout (str, len, len, printcharfun);
  1616         SAFE_FREE ();
  1617       }
  1618       return true;
  1619 
  1620     case PVEC_BOOL_VECTOR:
  1621       {
  1622         EMACS_INT size = bool_vector_size (obj);
  1623         ptrdiff_t size_in_bytes = bool_vector_bytes (size);
  1624         ptrdiff_t real_size_in_bytes = size_in_bytes;
  1625         unsigned char *data = bool_vector_uchar_data (obj);
  1626 
  1627         int len = sprintf (buf, "#&%"pI"d\"", size);
  1628         strout (buf, len, len, printcharfun);
  1629 
  1630         /* Don't print more bytes than the specified maximum.
  1631            Negative values of print-length are invalid.  Treat them
  1632            like a print-length of nil.  */
  1633         if (FIXNATP (Vprint_length)
  1634             && XFIXNAT (Vprint_length) < size_in_bytes)
  1635           size_in_bytes = XFIXNAT (Vprint_length);
  1636 
  1637         for (ptrdiff_t i = 0; i < size_in_bytes; i++)
  1638           {
  1639             maybe_quit ();
  1640             unsigned char c = data[i];
  1641             if (c == '\n' && print_escape_newlines)
  1642               print_c_string ("\\n", printcharfun);
  1643             else if (c == '\f' && print_escape_newlines)
  1644               print_c_string ("\\f", printcharfun);
  1645             else if (c > '\177'
  1646                      || (print_escape_control_characters && c_iscntrl (c)))
  1647               {
  1648                 /* Use octal escapes to avoid encoding issues.  */
  1649                 octalout (c, data, i + 1, size_in_bytes, printcharfun);
  1650               }
  1651             else
  1652               {
  1653                 if (c == '\"' || c == '\\')
  1654                   printchar ('\\', printcharfun);
  1655                 printchar (c, printcharfun);
  1656               }
  1657           }
  1658 
  1659         if (size_in_bytes < real_size_in_bytes)
  1660           print_c_string (" ...", printcharfun);
  1661         printchar ('\"', printcharfun);
  1662       }
  1663       return true;
  1664 
  1665     default:
  1666       break;
  1667     }
  1668 
  1669   /* Then do all the pseudovector types that don't have a readable
  1670      syntax.  First check whether this is handled by
  1671      `print-unreadable-function'.  */
  1672   if (!NILP (Vprint_unreadable_function)
  1673       && FUNCTIONP (Vprint_unreadable_function))
  1674     {
  1675       specpdl_ref count = SPECPDL_INDEX ();
  1676       /* Bind `print-unreadable-function' to nil to avoid accidental
  1677          infinite recursion in the function called.  */
  1678       Lisp_Object func = Vprint_unreadable_function;
  1679       specbind (Qprint_unreadable_function, Qnil);
  1680 
  1681       /* If we're being called from `prin1-to-string' or the like,
  1682          we're now in the secret " prin1" buffer.  This can lead to
  1683          problems if, for instance, the callback function switches a
  1684          window to this buffer -- this will make Emacs segfault.  */
  1685       if (!NILP (Vprint__unreadable_callback_buffer)
  1686           && !NILP (Fbuffer_live_p (Vprint__unreadable_callback_buffer)))
  1687         {
  1688           record_unwind_current_buffer ();
  1689           set_buffer_internal (XBUFFER (Vprint__unreadable_callback_buffer));
  1690         }
  1691       Lisp_Object result = CALLN (Ffuncall, func, obj,
  1692                                   escapeflag? Qt: Qnil);
  1693       unbind_to (count, Qnil);
  1694 
  1695       if (!NILP (result))
  1696         {
  1697           if (STRINGP (result))
  1698             print_string (result, printcharfun);
  1699           /* It's handled, so stop processing here.  */
  1700           return true;
  1701         }
  1702     }
  1703 
  1704   /* Not handled; print unreadable object.  */
  1705   switch (PSEUDOVECTOR_TYPE (XVECTOR (obj)))
  1706     {
  1707     case PVEC_MARKER:
  1708       print_c_string ("#<marker ", printcharfun);
  1709       /* Do you think this is necessary?  */
  1710       if (XMARKER (obj)->insertion_type != 0)
  1711         print_c_string ("(moves after insertion) ", printcharfun);
  1712       if (! XMARKER (obj)->buffer)
  1713         print_c_string ("in no buffer", printcharfun);
  1714       else
  1715         {
  1716           int len = sprintf (buf, "at %"pD"d in ", marker_position (obj));
  1717           strout (buf, len, len, printcharfun);
  1718           print_string (BVAR (XMARKER (obj)->buffer, name), printcharfun);
  1719         }
  1720       printchar ('>', printcharfun);
  1721       break;
  1722 
  1723     case PVEC_SYMBOL_WITH_POS:
  1724       {
  1725         struct Lisp_Symbol_With_Pos *sp = XSYMBOL_WITH_POS (obj);
  1726         if (print_symbols_bare)
  1727           print_object (sp->sym, printcharfun, escapeflag);
  1728         else
  1729           {
  1730             print_c_string ("#<symbol ", printcharfun);
  1731             if (BARE_SYMBOL_P (sp->sym))
  1732               print_object (sp->sym, printcharfun, escapeflag);
  1733             else
  1734               print_c_string ("NOT A SYMBOL!!", printcharfun);
  1735             if (FIXNUMP (sp->pos))
  1736               {
  1737                 print_c_string (" at ", printcharfun);
  1738                 print_object (sp->pos, printcharfun, escapeflag);
  1739               }
  1740             else
  1741               print_c_string (" NOT A POSITION!!", printcharfun);
  1742             printchar ('>', printcharfun);
  1743           }
  1744       }
  1745       break;
  1746 
  1747     case PVEC_OVERLAY:
  1748       print_c_string ("#<overlay ", printcharfun);
  1749       if (! OVERLAY_BUFFER (obj))
  1750         print_c_string ("in no buffer", printcharfun);
  1751       else
  1752         {
  1753           int len = sprintf (buf, "from %"pD"d to %"pD"d in ",
  1754                              OVERLAY_START (obj),
  1755                              OVERLAY_END   (obj));
  1756           strout (buf, len, len, printcharfun);
  1757           print_string (BVAR (OVERLAY_BUFFER (obj), name),
  1758                         printcharfun);
  1759         }
  1760       printchar ('>', printcharfun);
  1761       break;
  1762 
  1763     case PVEC_USER_PTR:
  1764       {
  1765         print_c_string ("#<user-ptr ", printcharfun);
  1766         int i = sprintf (buf, "ptr=%p finalizer=%p",
  1767                          XUSER_PTR (obj)->p,
  1768                          (void *) XUSER_PTR (obj)->finalizer);
  1769         strout (buf, i, i, printcharfun);
  1770         printchar ('>', printcharfun);
  1771       }
  1772       break;
  1773 
  1774     case PVEC_FINALIZER:
  1775       print_c_string ("#<finalizer", printcharfun);
  1776       if (NILP (XFINALIZER (obj)->function))
  1777         print_c_string (" used", printcharfun);
  1778       printchar ('>', printcharfun);
  1779       break;
  1780 
  1781     case PVEC_MISC_PTR:
  1782       {
  1783         /* This shouldn't happen in normal usage, but let's
  1784            print it anyway for the benefit of the debugger.  */
  1785         int i = sprintf (buf, "#<ptr %p>", xmint_pointer (obj));
  1786         strout (buf, i, i, printcharfun);
  1787       }
  1788       break;
  1789 
  1790     case PVEC_PROCESS:
  1791       if (escapeflag)
  1792         {
  1793           print_c_string ("#<process ", printcharfun);
  1794           print_string (XPROCESS (obj)->name, printcharfun);
  1795           printchar ('>', printcharfun);
  1796         }
  1797       else
  1798         print_string (XPROCESS (obj)->name, printcharfun);
  1799       break;
  1800 
  1801     case PVEC_SUBR:
  1802       print_c_string ("#<subr ", printcharfun);
  1803       print_c_string (XSUBR (obj)->symbol_name, printcharfun);
  1804       printchar ('>', printcharfun);
  1805       break;
  1806 
  1807     case PVEC_XWIDGET:
  1808 #ifdef HAVE_XWIDGETS
  1809       {
  1810         if (NILP (XXWIDGET (obj)->buffer))
  1811           print_c_string ("#<killed xwidget>", printcharfun);
  1812         else
  1813           {
  1814 #ifdef USE_GTK
  1815             int len = sprintf (buf, "#<xwidget %u %p>",
  1816                                XXWIDGET (obj)->xwidget_id,
  1817                                XXWIDGET (obj)->widget_osr);
  1818 #else
  1819             int len = sprintf (buf, "#<xwidget %u %p>",
  1820                                XXWIDGET (obj)->xwidget_id,
  1821                                XXWIDGET (obj)->xwWidget);
  1822 #endif
  1823             strout (buf, len, len, printcharfun);
  1824           }
  1825         break;
  1826       }
  1827 #else
  1828       emacs_abort ();
  1829 #endif
  1830     case PVEC_XWIDGET_VIEW:
  1831       print_c_string ("#<xwidget view", printcharfun);
  1832       printchar ('>', printcharfun);
  1833       break;
  1834 
  1835     case PVEC_WINDOW:
  1836       {
  1837         int len = sprintf (buf, "#<window %"pI"d",
  1838                            XWINDOW (obj)->sequence_number);
  1839         strout (buf, len, len, printcharfun);
  1840         if (BUFFERP (XWINDOW (obj)->contents))
  1841           {
  1842             print_c_string (" on ", printcharfun);
  1843             print_string (BVAR (XBUFFER (XWINDOW (obj)->contents), name),
  1844                           printcharfun);
  1845           }
  1846         printchar ('>', printcharfun);
  1847       }
  1848       break;
  1849 
  1850     case PVEC_TERMINAL:
  1851       {
  1852         struct terminal *t = XTERMINAL (obj);
  1853         int len = sprintf (buf, "#<terminal %d", t->id);
  1854         strout (buf, len, len, printcharfun);
  1855         if (t->name)
  1856           {
  1857             print_c_string (" on ", printcharfun);
  1858             print_c_string (t->name, printcharfun);
  1859           }
  1860         printchar ('>', printcharfun);
  1861       }
  1862       break;
  1863 
  1864     case PVEC_BUFFER:
  1865       if (!BUFFER_LIVE_P (XBUFFER (obj)))
  1866         print_c_string ("#<killed buffer>", printcharfun);
  1867       else if (escapeflag)
  1868         {
  1869           print_c_string ("#<buffer ", printcharfun);
  1870           print_string (BVAR (XBUFFER (obj), name), printcharfun);
  1871           printchar ('>', printcharfun);
  1872         }
  1873       else
  1874         print_string (BVAR (XBUFFER (obj), name), printcharfun);
  1875       break;
  1876 
  1877     case PVEC_WINDOW_CONFIGURATION:
  1878       print_c_string ("#<window-configuration>", printcharfun);
  1879       break;
  1880 
  1881     case PVEC_FRAME:
  1882       {
  1883         void *ptr = XFRAME (obj);
  1884         Lisp_Object frame_name = XFRAME (obj)->name;
  1885 
  1886         print_c_string ((FRAME_LIVE_P (XFRAME (obj))
  1887                          ? "#<frame "
  1888                          : "#<dead frame "),
  1889                         printcharfun);
  1890         if (!STRINGP (frame_name))
  1891           {
  1892             /* A frame could be too young and have no name yet;
  1893                don't crash.  */
  1894             if (SYMBOLP (frame_name))
  1895               frame_name = Fsymbol_name (frame_name);
  1896             else        /* can't happen: name should be either nil or string */
  1897               frame_name = build_string ("*INVALID*FRAME*NAME*");
  1898           }
  1899         print_string (frame_name, printcharfun);
  1900         int len = sprintf (buf, " %p>", ptr);
  1901         strout (buf, len, len, printcharfun);
  1902       }
  1903       break;
  1904 
  1905     case PVEC_FONT:
  1906       {
  1907         if (! FONT_OBJECT_P (obj))
  1908           {
  1909             if (FONT_SPEC_P (obj))
  1910               print_c_string ("#<font-spec", printcharfun);
  1911             else
  1912               print_c_string ("#<font-entity", printcharfun);
  1913             for (int i = 0; i < FONT_SPEC_MAX; i++)
  1914               {
  1915                 /* FONT_EXTRA_INDEX can contain private information in
  1916                    font entities which isn't safe to print.  */
  1917                 if (i != FONT_EXTRA_INDEX || !FONT_ENTITY_P (obj))
  1918                   {
  1919                     printchar (' ', printcharfun);
  1920                     if (i < FONT_WEIGHT_INDEX || i > FONT_WIDTH_INDEX)
  1921                       print_object (AREF (obj, i), printcharfun, escapeflag);
  1922                     else
  1923                       print_object (font_style_symbolic (obj, i, 0),
  1924                                     printcharfun, escapeflag);
  1925                   }
  1926               }
  1927           }
  1928         else
  1929           {
  1930             print_c_string ("#<font-object ", printcharfun);
  1931             print_object (AREF (obj, FONT_NAME_INDEX), printcharfun,
  1932                           escapeflag);
  1933           }
  1934         printchar ('>', printcharfun);
  1935       }
  1936       break;
  1937 
  1938     case PVEC_THREAD:
  1939       print_c_string ("#<thread ", printcharfun);
  1940       if (STRINGP (XTHREAD (obj)->name))
  1941         print_string (XTHREAD (obj)->name, printcharfun);
  1942       else
  1943         {
  1944           void *p = XTHREAD (obj);
  1945           int len = sprintf (buf, "%p", p);
  1946           strout (buf, len, len, printcharfun);
  1947         }
  1948       printchar ('>', printcharfun);
  1949       break;
  1950 
  1951     case PVEC_MUTEX:
  1952       print_c_string ("#<mutex ", printcharfun);
  1953       if (STRINGP (XMUTEX (obj)->name))
  1954         print_string (XMUTEX (obj)->name, printcharfun);
  1955       else
  1956         {
  1957           void *p = XMUTEX (obj);
  1958           int len = sprintf (buf, "%p", p);
  1959           strout (buf, len, len, printcharfun);
  1960         }
  1961       printchar ('>', printcharfun);
  1962       break;
  1963 
  1964     case PVEC_CONDVAR:
  1965       print_c_string ("#<condvar ", printcharfun);
  1966       if (STRINGP (XCONDVAR (obj)->name))
  1967         print_string (XCONDVAR (obj)->name, printcharfun);
  1968       else
  1969         {
  1970           void *p = XCONDVAR (obj);
  1971           int len = sprintf (buf, "%p", p);
  1972           strout (buf, len, len, printcharfun);
  1973         }
  1974       printchar ('>', printcharfun);
  1975       break;
  1976 
  1977 #ifdef HAVE_MODULES
  1978     case PVEC_MODULE_FUNCTION:
  1979       {
  1980         print_c_string ("#<module function ", printcharfun);
  1981         const struct Lisp_Module_Function *function = XMODULE_FUNCTION (obj);
  1982         module_funcptr ptr = module_function_address (function);
  1983         char const *file;
  1984         char const *symbol;
  1985         dynlib_addr (ptr, &file, &symbol);
  1986 
  1987         if (symbol == NULL)
  1988           print_pointer (printcharfun, buf, "at", data_from_funcptr (ptr));
  1989         else
  1990           print_c_string (symbol, printcharfun);
  1991 
  1992         void *data = module_function_data (function);
  1993         if (data != NULL)
  1994           print_pointer (printcharfun, buf, " with data", data);
  1995 
  1996         if (file != NULL)
  1997           {
  1998             print_c_string (" from ", printcharfun);
  1999             print_c_string (file, printcharfun);
  2000           }
  2001 
  2002         printchar ('>', printcharfun);
  2003       }
  2004       break;
  2005 #endif
  2006 #ifdef HAVE_NATIVE_COMP
  2007     case PVEC_NATIVE_COMP_UNIT:
  2008       {
  2009         struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (obj);
  2010         print_c_string ("#<native compilation unit: ", printcharfun);
  2011         print_string (cu->file, printcharfun);
  2012         printchar (' ', printcharfun);
  2013         print_object (cu->optimize_qualities, printcharfun, escapeflag);
  2014         printchar ('>', printcharfun);
  2015       }
  2016       break;
  2017 #endif
  2018 
  2019 #ifdef HAVE_TREE_SITTER
  2020     case PVEC_TS_PARSER:
  2021       print_c_string ("#<treesit-parser for ", printcharfun);
  2022       Lisp_Object language = XTS_PARSER (obj)->language_symbol;
  2023       /* No need to print the buffer because it's not that useful: we
  2024          usually know which buffer a parser belongs to.  */
  2025       print_string (Fsymbol_name (language), printcharfun);
  2026       printchar ('>', printcharfun);
  2027       break;
  2028     case PVEC_TS_NODE:
  2029       /* Prints #<treesit-node (identifier) in 12-15> or
  2030          #<treesit-node "keyword" in 28-31>. */
  2031       print_c_string ("#<treesit-node", printcharfun);
  2032       if (!treesit_node_uptodate_p (obj))
  2033         {
  2034           print_c_string ("-outdated>", printcharfun);
  2035           break;
  2036         }
  2037       printchar (' ', printcharfun);
  2038       /* Now the node must be up-to-date, and calling functions like
  2039          Ftreesit_node_start will not signal.  */
  2040       bool named = treesit_named_node_p (XTS_NODE (obj)->node);
  2041       /* We used to use () as delimiters for named nodes, but that
  2042          confuses pretty-printing a tad bit.  There might be more
  2043          little breakages here and there if we print parenthesizes
  2044          inside an object, so I guess better not do it.
  2045          (bug#60696)  */
  2046       const char *delim1 = named ? "" : "\"";
  2047       const char *delim2 = named ? "" : "\"";
  2048       print_c_string (delim1, printcharfun);
  2049       print_string (Ftreesit_node_type (obj), printcharfun);
  2050       print_c_string (delim2, printcharfun);
  2051       print_c_string (" in ", printcharfun);
  2052       print_object (Ftreesit_node_start (obj), printcharfun, escapeflag);
  2053       printchar ('-', printcharfun);
  2054       print_object (Ftreesit_node_end (obj), printcharfun, escapeflag);
  2055       printchar ('>', printcharfun);
  2056       break;
  2057     case PVEC_TS_COMPILED_QUERY:
  2058       print_c_string ("#<treesit-compiled-query>", printcharfun);
  2059       break;
  2060 #endif
  2061 
  2062     case PVEC_SQLITE:
  2063       {
  2064         print_c_string ("#<sqlite ", printcharfun);
  2065         int i = sprintf (buf, "db=%p", XSQLITE (obj)->db);
  2066         strout (buf, i, i, printcharfun);
  2067         if (XSQLITE (obj)->is_statement)
  2068           {
  2069             i = sprintf (buf, " stmt=%p", XSQLITE (obj)->stmt);
  2070             strout (buf, i, i, printcharfun);
  2071           }
  2072         print_c_string (" name=", printcharfun);
  2073         print_c_string (XSQLITE (obj)->name, printcharfun);
  2074         printchar ('>', printcharfun);
  2075       }
  2076       break;
  2077 
  2078     default:
  2079       emacs_abort ();
  2080     }
  2081 
  2082   return true;
  2083 }
  2084 
  2085 static char
  2086 named_escape (int i)
  2087 {
  2088   switch (i)
  2089     {
  2090     case '\b': return 'b';
  2091     case '\t': return 't';
  2092     case '\n': return 'n';
  2093     case '\f': return 'f';
  2094     case '\r': return 'r';
  2095     case ' ':  return 's';
  2096       /* \a, \v, \e and \d are excluded from printing as escapes since
  2097          they are somewhat rare as characters and more likely to be
  2098          plain integers. */
  2099     }
  2100   return 0;
  2101 }
  2102 
  2103 enum print_entry_type
  2104   {
  2105     PE_list,                    /* print rest of list */
  2106     PE_rbrac,                   /* print ")" */
  2107     PE_vector,                  /* print rest of vector */
  2108     PE_hash,                    /* print rest of hash data */
  2109   };
  2110 
  2111 struct print_stack_entry
  2112 {
  2113   enum print_entry_type type;
  2114 
  2115   union
  2116   {
  2117     struct
  2118     {
  2119       Lisp_Object last;         /* cons whose car was just printed  */
  2120       intmax_t maxlen;          /* max number of elements left to print */
  2121       /* State for Brent cycle detection.  See
  2122          Brent RP. BIT. 1980;20(2):176-184. doi:10.1007/BF01933190
  2123          https://maths-people.anu.edu.au/~brent/pd/rpb051i.pdf */
  2124       Lisp_Object tortoise;     /* slow pointer */
  2125       ptrdiff_t n;              /* tortoise step countdown */
  2126       ptrdiff_t m;              /* tortoise step period */
  2127       intmax_t tortoise_idx;    /* index of tortoise */
  2128     } list;
  2129 
  2130     struct
  2131     {
  2132       Lisp_Object obj;          /* object to print after " . " */
  2133     } dotted_cdr;
  2134 
  2135     struct
  2136     {
  2137       Lisp_Object obj;          /* vector object */
  2138       ptrdiff_t size;           /* length of vector */
  2139       ptrdiff_t idx;            /* index of next element */
  2140       const char *end;          /* string to print at end */
  2141       bool truncated;           /* whether to print "..." before end */
  2142     } vector;
  2143 
  2144     struct
  2145     {
  2146       Lisp_Object obj;          /* hash-table object */
  2147       ptrdiff_t nobjs;          /* number of keys and values to print */
  2148       ptrdiff_t idx;            /* index of key-value pair */
  2149       ptrdiff_t printed;        /* number of keys and values printed */
  2150       bool truncated;           /* whether to print "..." before end */
  2151     } hash;
  2152   } u;
  2153 };
  2154 
  2155 struct print_stack
  2156 {
  2157   struct print_stack_entry *stack;  /* base of stack */
  2158   ptrdiff_t size;                   /* allocated size in entries */
  2159   ptrdiff_t sp;                     /* current number of entries */
  2160 };
  2161 
  2162 static struct print_stack prstack = {NULL, 0, 0};
  2163 
  2164 NO_INLINE static void
  2165 grow_print_stack (void)
  2166 {
  2167   struct print_stack *ps = &prstack;
  2168   eassert (ps->sp == ps->size);
  2169   ps->stack = xpalloc (ps->stack, &ps->size, 1, -1, sizeof *ps->stack);
  2170   eassert (ps->sp < ps->size);
  2171 }
  2172 
  2173 static inline void
  2174 print_stack_push (struct print_stack_entry e)
  2175 {
  2176   if (prstack.sp >= prstack.size)
  2177     grow_print_stack ();
  2178   prstack.stack[prstack.sp++] = e;
  2179 }
  2180 
  2181 static void
  2182 print_stack_push_vector (const char *lbrac, const char *rbrac,
  2183                          Lisp_Object obj, ptrdiff_t start, ptrdiff_t size,
  2184                          Lisp_Object printcharfun)
  2185 {
  2186   print_c_string (lbrac, printcharfun);
  2187 
  2188   ptrdiff_t print_size = ((FIXNATP (Vprint_length)
  2189                            && XFIXNAT (Vprint_length) < size)
  2190                           ? XFIXNAT (Vprint_length) : size);
  2191   print_stack_push ((struct print_stack_entry){
  2192       .type = PE_vector,
  2193       .u.vector.obj = obj,
  2194       .u.vector.size = print_size,
  2195       .u.vector.idx = start,
  2196       .u.vector.end = rbrac,
  2197       .u.vector.truncated = (print_size < size),
  2198     });
  2199 }
  2200 
  2201 static void
  2202 print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
  2203 {
  2204   ptrdiff_t base_depth = print_depth;
  2205   ptrdiff_t base_sp = prstack.sp;
  2206   char buf[max (sizeof "from..to..in " + 2 * INT_STRLEN_BOUND (EMACS_INT),
  2207                 max (sizeof " . #" + INT_STRLEN_BOUND (intmax_t),
  2208                      max ((sizeof " with data 0x"
  2209                            + (UINTMAX_WIDTH + 4 - 1) / 4),
  2210                           40)))];
  2211   current_thread->stack_top = NEAR_STACK_TOP (buf);
  2212 
  2213  print_obj:
  2214   maybe_quit ();
  2215 
  2216   /* Detect circularities and truncate them.  */
  2217   if (NILP (Vprint_circle))
  2218     {
  2219       /* Simple but incomplete way.  */
  2220       if (print_depth >= PRINT_CIRCLE)
  2221         error ("Apparently circular structure being printed");
  2222 
  2223       for (int i = 0; i < print_depth; i++)
  2224         if (BASE_EQ (obj, being_printed[i]))
  2225           {
  2226             int len = sprintf (buf, "#%d", i);
  2227             strout (buf, len, len, printcharfun);
  2228             goto next_obj;
  2229           }
  2230       being_printed[print_depth] = obj;
  2231     }
  2232   else if (PRINT_CIRCLE_CANDIDATE_P (obj))
  2233     {
  2234       /* With the print-circle feature.  */
  2235       Lisp_Object num = Fgethash (obj, Vprint_number_table, Qnil);
  2236       if (FIXNUMP (num))
  2237         {
  2238           EMACS_INT n = XFIXNUM (num);
  2239           if (n < 0)
  2240             { /* Add a prefix #n= if OBJ has not yet been printed;
  2241                  that is, its status field is nil.  */
  2242               int len = sprintf (buf, "#%"pI"d=", -n);
  2243               strout (buf, len, len, printcharfun);
  2244               /* OBJ is going to be printed.  Remember that fact.  */
  2245               Fputhash (obj, make_fixnum (- n), Vprint_number_table);
  2246             }
  2247           else
  2248             {
  2249               /* Just print #n# if OBJ has already been printed.  */
  2250               int len = sprintf (buf, "#%"pI"d#", n);
  2251               strout (buf, len, len, printcharfun);
  2252               goto next_obj;
  2253             }
  2254         }
  2255     }
  2256 
  2257   print_depth++;
  2258 
  2259   switch (XTYPE (obj))
  2260     {
  2261     case_Lisp_Int:
  2262       {
  2263         EMACS_INT i = XFIXNUM (obj);
  2264         char escaped_name;
  2265 
  2266         if (print_integers_as_characters && i >= 0 && i <= MAX_UNICODE_CHAR
  2267             && ((escaped_name = named_escape (i))
  2268                 || graphic_base_p (i)))
  2269           {
  2270             printchar ('?', printcharfun);
  2271             if (escaped_name)
  2272               {
  2273                 printchar ('\\', printcharfun);
  2274                 i = escaped_name;
  2275               }
  2276             else if (escapeflag
  2277                      && (i == ';' || i == '\"' || i == '\'' || i == '\\'
  2278                          || i == '(' || i == ')'
  2279                          || i == '{' || i == '}'
  2280                          || i == '[' || i == ']'))
  2281               printchar ('\\', printcharfun);
  2282             printchar (i, printcharfun);
  2283           }
  2284         else
  2285           {
  2286             char *end = buf + sizeof buf;
  2287             char *start = fixnum_to_string (i, buf, end);
  2288             ptrdiff_t len = end - start;
  2289             strout (start, len, len, printcharfun);
  2290           }
  2291       }
  2292       break;
  2293 
  2294     case Lisp_Float:
  2295       {
  2296         char pigbuf[FLOAT_TO_STRING_BUFSIZE];
  2297         int len = float_to_string (pigbuf, XFLOAT_DATA (obj));
  2298         strout (pigbuf, len, len, printcharfun);
  2299       }
  2300       break;
  2301 
  2302     case Lisp_String:
  2303       if (!escapeflag)
  2304         print_string (obj, printcharfun);
  2305       else
  2306         {
  2307           ptrdiff_t i, i_byte;
  2308           ptrdiff_t size_byte;
  2309           /* True means we must ensure that the next character we output
  2310              cannot be taken as part of a hex character escape.  */
  2311           bool need_nonhex = false;
  2312           bool multibyte = STRING_MULTIBYTE (obj);
  2313 
  2314           if (! EQ (Vprint_charset_text_property, Qt))
  2315             obj = print_prune_string_charset (obj);
  2316 
  2317           if (string_intervals (obj))
  2318             print_c_string ("#(", printcharfun);
  2319 
  2320           printchar ('\"', printcharfun);
  2321           size_byte = SBYTES (obj);
  2322 
  2323           for (i = 0, i_byte = 0; i_byte < size_byte;)
  2324             {
  2325               /* Here, we must convert each multi-byte form to the
  2326                  corresponding character code before handing it to
  2327                  printchar.  */
  2328               int c = fetch_string_char_advance (obj, &i, &i_byte);
  2329 
  2330               maybe_quit ();
  2331 
  2332               if (multibyte
  2333                   ? (CHAR_BYTE8_P (c) && (c = CHAR_TO_BYTE8 (c), true))
  2334                   : (SINGLE_BYTE_CHAR_P (c) && ! ASCII_CHAR_P (c)
  2335                      && print_escape_nonascii))
  2336                 {
  2337                   /* When printing a raw 8-bit byte in a multibyte buffer, or
  2338                      (when requested) a non-ASCII character in a unibyte buffer,
  2339                      print single-byte non-ASCII string chars
  2340                      using octal escapes.  */
  2341                   octalout (c, SDATA (obj), i_byte, size_byte, printcharfun);
  2342                   need_nonhex = false;
  2343                 }
  2344               else if (multibyte
  2345                        && ! ASCII_CHAR_P (c) && print_escape_multibyte)
  2346                 {
  2347                   /* When requested, print multibyte chars using
  2348                      hex escapes.  */
  2349                   char outbuf[sizeof "\\x" + INT_STRLEN_BOUND (c)];
  2350                   int len = sprintf (outbuf, "\\x%04x", c + 0u);
  2351                   strout (outbuf, len, len, printcharfun);
  2352                   need_nonhex = true;
  2353                 }
  2354               else
  2355                 {
  2356                   /* If we just had a hex escape, and this character
  2357                      could be taken as part of it,
  2358                      output `\ ' to prevent that.  */
  2359                   if (c_isxdigit (c))
  2360                     {
  2361                       if (need_nonhex)
  2362                         print_c_string ("\\ ", printcharfun);
  2363                       printchar (c, printcharfun);
  2364                     }
  2365                   else if (c == '\n' && print_escape_newlines
  2366                            ? (c = 'n', true)
  2367                            : c == '\f' && print_escape_newlines
  2368                            ? (c = 'f', true)
  2369                            : c == '\"' || c == '\\')
  2370                     {
  2371                       printchar ('\\', printcharfun);
  2372                       printchar (c, printcharfun);
  2373                     }
  2374                   else if (print_escape_control_characters && c_iscntrl (c))
  2375                     octalout (c, SDATA (obj), i_byte, size_byte, printcharfun);
  2376                   else if (!multibyte
  2377                            && SINGLE_BYTE_CHAR_P (c)
  2378                            && !ASCII_CHAR_P (c))
  2379                     printchar (BYTE8_TO_CHAR (c), printcharfun);
  2380                   else
  2381                     printchar (c, printcharfun);
  2382                   need_nonhex = false;
  2383                 }
  2384             }
  2385           printchar ('\"', printcharfun);
  2386 
  2387           if (string_intervals (obj))
  2388             {
  2389               traverse_intervals (string_intervals (obj),
  2390                                   0, print_interval, printcharfun);
  2391               printchar (')', printcharfun);
  2392             }
  2393         }
  2394       break;
  2395 
  2396     case Lisp_Symbol:
  2397       {
  2398         Lisp_Object name = SYMBOL_NAME (obj);
  2399         ptrdiff_t size_byte = SBYTES (name);
  2400 
  2401         char *p = SSDATA (name);
  2402         bool signedp = *p == '-' || *p == '+';
  2403         ptrdiff_t len;
  2404         bool confusing =
  2405           /* Set CONFUSING if NAME looks like a number, calling
  2406              string_to_number for non-obvious cases.  */
  2407           ((c_isdigit (p[signedp]) || p[signedp] == '.')
  2408            && !NILP (string_to_number (p, 10, &len))
  2409            && len == size_byte)
  2410           /* We don't escape "." or "?" (unless they're the first
  2411              character in the symbol name).  */
  2412           || *p == '?'
  2413           || *p == '.';
  2414 
  2415         if (! NILP (Vprint_gensym)
  2416             && !SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (obj))
  2417           print_c_string ("#:", printcharfun);
  2418         else if (size_byte == 0)
  2419           {
  2420             print_c_string ("##", printcharfun);
  2421             break;
  2422           }
  2423 
  2424         ptrdiff_t i = 0;
  2425         for (ptrdiff_t i_byte = 0; i_byte < size_byte; )
  2426           {
  2427             /* Here, we must convert each multi-byte form to the
  2428                corresponding character code before handing it to PRINTCHAR.  */
  2429             int c = fetch_string_char_advance (name, &i, &i_byte);
  2430             maybe_quit ();
  2431 
  2432             if (escapeflag)
  2433               {
  2434                 if (c == '\"' || c == '\\' || c == '\''
  2435                     || c == ';' || c == '#' || c == '(' || c == ')'
  2436                     || c == ',' || c == '`'
  2437                     || c == '[' || c == ']' || c <= 040
  2438                     || c == NO_BREAK_SPACE
  2439                     || confusing)
  2440                   {
  2441                     printchar ('\\', printcharfun);
  2442                     confusing = false;
  2443                   }
  2444               }
  2445             printchar (c, printcharfun);
  2446           }
  2447       }
  2448       break;
  2449 
  2450     case Lisp_Cons:
  2451       /* If deeper than spec'd depth, print placeholder.  */
  2452       if (FIXNUMP (Vprint_level)
  2453           && print_depth > XFIXNUM (Vprint_level))
  2454         print_c_string ("...", printcharfun);
  2455       else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
  2456                && EQ (XCAR (obj), Qquote))
  2457         {
  2458           printchar ('\'', printcharfun);
  2459           obj = XCAR (XCDR (obj));
  2460           --print_depth;        /* tail recursion */
  2461           goto print_obj;
  2462         }
  2463       else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
  2464                && EQ (XCAR (obj), Qfunction))
  2465         {
  2466           print_c_string ("#'", printcharfun);
  2467           obj = XCAR (XCDR (obj));
  2468           --print_depth;        /* tail recursion */
  2469           goto print_obj;
  2470         }
  2471       /* FIXME: Do we really need the new_backquote_output gating of
  2472          special syntax for comma and comma-at?  There is basically no
  2473          benefit from it at all, and it would be nice to get rid of
  2474          the recursion here without additional complexity.  */
  2475       else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
  2476                && EQ (XCAR (obj), Qbackquote))
  2477         {
  2478           printchar ('`', printcharfun);
  2479           new_backquote_output++;
  2480           print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
  2481           new_backquote_output--;
  2482         }
  2483       else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
  2484                && (EQ (XCAR (obj), Qcomma)
  2485                    || EQ (XCAR (obj), Qcomma_at))
  2486                && new_backquote_output)
  2487         {
  2488           print_object (XCAR (obj), printcharfun, false);
  2489           new_backquote_output--;
  2490           print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
  2491           new_backquote_output++;
  2492         }
  2493       else
  2494         {
  2495           printchar ('(', printcharfun);
  2496           /* Negative values of print-length are invalid in CL.
  2497              Treat them like nil, as CMUCL does.  */
  2498           intmax_t print_length = (FIXNATP (Vprint_length)
  2499                                    ? XFIXNAT (Vprint_length)
  2500                                    : INTMAX_MAX);
  2501           if (print_length == 0)
  2502             print_c_string ("...)", printcharfun);
  2503           else
  2504             {
  2505               print_stack_push ((struct print_stack_entry){
  2506                   .type = PE_list,
  2507                   .u.list.last = obj,
  2508                   .u.list.maxlen = print_length,
  2509                   .u.list.tortoise = obj,
  2510                   .u.list.n = 2,
  2511                   .u.list.m = 2,
  2512                   .u.list.tortoise_idx = 0,
  2513                 });
  2514               /* print the car */
  2515               obj = XCAR (obj);
  2516               goto print_obj;
  2517             }
  2518         }
  2519       break;
  2520 
  2521     case Lisp_Vectorlike:
  2522       /* First do all the vectorlike types that have a readable syntax.  */
  2523       switch (PSEUDOVECTOR_TYPE (XVECTOR (obj)))
  2524         {
  2525         case PVEC_NORMAL_VECTOR:
  2526           {
  2527             print_stack_push_vector ("[", "]", obj, 0, ASIZE (obj),
  2528                                      printcharfun);
  2529             goto next_obj;
  2530           }
  2531         case PVEC_RECORD:
  2532           {
  2533             print_stack_push_vector ("#s(", ")", obj, 0, PVSIZE (obj),
  2534                                      printcharfun);
  2535             goto next_obj;
  2536           }
  2537         case PVEC_COMPILED:
  2538           {
  2539             print_stack_push_vector ("#[", "]", obj, 0, PVSIZE (obj),
  2540                                      printcharfun);
  2541             goto next_obj;
  2542           }
  2543         case PVEC_CHAR_TABLE:
  2544           {
  2545             print_stack_push_vector ("#^[", "]", obj, 0, PVSIZE (obj),
  2546                                      printcharfun);
  2547             goto next_obj;
  2548           }
  2549         case PVEC_SUB_CHAR_TABLE:
  2550           {
  2551             /* Make each lowest sub_char_table start a new line.
  2552                Otherwise we'll make a line extremely long, which
  2553                results in slow redisplay.  */
  2554             if (XSUB_CHAR_TABLE (obj)->depth == 3)
  2555               printchar ('\n', printcharfun);
  2556             print_c_string ("#^^[", printcharfun);
  2557             int n = sprintf (buf, "%d %d",
  2558                              XSUB_CHAR_TABLE (obj)->depth,
  2559                              XSUB_CHAR_TABLE (obj)->min_char);
  2560             strout (buf, n, n, printcharfun);
  2561             print_stack_push_vector ("", "]", obj,
  2562                                      SUB_CHAR_TABLE_OFFSET, PVSIZE (obj),
  2563                                      printcharfun);
  2564             goto next_obj;
  2565           }
  2566         case PVEC_HASH_TABLE:
  2567           {
  2568             struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
  2569             /* Implement a readable output, e.g.:
  2570                #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
  2571             /* Always print the size.  */
  2572             int len = sprintf (buf, "#s(hash-table size %"pD"d",
  2573                                HASH_TABLE_SIZE (h));
  2574             strout (buf, len, len, printcharfun);
  2575 
  2576             if (!NILP (h->test.name))
  2577               {
  2578                 print_c_string (" test ", printcharfun);
  2579                 print_object (h->test.name, printcharfun, escapeflag);
  2580               }
  2581 
  2582             if (!NILP (h->weak))
  2583               {
  2584                 print_c_string (" weakness ", printcharfun);
  2585                 print_object (h->weak, printcharfun, escapeflag);
  2586               }
  2587 
  2588             print_c_string (" rehash-size ", printcharfun);
  2589             print_object (Fhash_table_rehash_size (obj),
  2590                           printcharfun, escapeflag);
  2591 
  2592             print_c_string (" rehash-threshold ", printcharfun);
  2593             print_object (Fhash_table_rehash_threshold (obj),
  2594                           printcharfun, escapeflag);
  2595 
  2596             if (h->purecopy)
  2597               print_c_string (" purecopy t", printcharfun);
  2598 
  2599             print_c_string (" data (", printcharfun);
  2600 
  2601             ptrdiff_t size = h->count;
  2602             /* Don't print more elements than the specified maximum.  */
  2603             if (FIXNATP (Vprint_length) && XFIXNAT (Vprint_length) < size)
  2604               size = XFIXNAT (Vprint_length);
  2605 
  2606             print_stack_push ((struct print_stack_entry){
  2607                 .type = PE_hash,
  2608                 .u.hash.obj = obj,
  2609                 .u.hash.nobjs = size * 2,
  2610                 .u.hash.idx = 0,
  2611                 .u.hash.printed = 0,
  2612                 .u.hash.truncated = (size < h->count),
  2613               });
  2614             goto next_obj;
  2615           }
  2616 
  2617         default:
  2618           break;
  2619         }
  2620 
  2621       if (print_vectorlike (obj, printcharfun, escapeflag, buf))
  2622         break;
  2623       FALLTHROUGH;
  2624 
  2625     default:
  2626       {
  2627         int len;
  2628         /* We're in trouble if this happens!
  2629            Probably should just emacs_abort ().  */
  2630         print_c_string ("#<EMACS BUG: INVALID DATATYPE ", printcharfun);
  2631         if (VECTORLIKEP (obj))
  2632           len = sprintf (buf, "(PVEC 0x%08zx)", (size_t) ASIZE (obj));
  2633         else
  2634           len = sprintf (buf, "(0x%02x)", (unsigned) XTYPE (obj));
  2635         strout (buf, len, len, printcharfun);
  2636         print_c_string ((" Save your buffers immediately"
  2637                          " and please report this bug>"),
  2638                         printcharfun);
  2639         break;
  2640       }
  2641     }
  2642   print_depth--;
  2643 
  2644  next_obj:
  2645   if (prstack.sp > base_sp)
  2646     {
  2647       /* Handle a continuation on the print stack.  */
  2648       struct print_stack_entry *e = &prstack.stack[prstack.sp - 1];
  2649       switch (e->type)
  2650         {
  2651         case PE_list:
  2652           {
  2653             /* after "(" ELEM (* " " ELEM) */
  2654             Lisp_Object next = XCDR (e->u.list.last);
  2655             if (NILP (next))
  2656               {
  2657                 /* end of list: print ")" */
  2658                 printchar (')', printcharfun);
  2659                 --prstack.sp;
  2660                 --print_depth;
  2661                 goto next_obj;
  2662               }
  2663             else if (CONSP (next))
  2664               {
  2665                 if (!NILP (Vprint_circle))
  2666                   {
  2667                     /* With the print-circle feature.  */
  2668                     Lisp_Object num = Fgethash (next, Vprint_number_table,
  2669                                                 Qnil);
  2670                     if (FIXNUMP (num))
  2671                       {
  2672                         print_c_string (" . ", printcharfun);
  2673                         obj = next;
  2674                         e->type = PE_rbrac;
  2675                         goto print_obj;
  2676                       }
  2677                   }
  2678 
  2679                 /* list continues: print " " ELEM ... */
  2680 
  2681                 printchar (' ', printcharfun);
  2682 
  2683                 --e->u.list.maxlen;
  2684                 if (e->u.list.maxlen <= 0)
  2685                   {
  2686                     print_c_string ("...)", printcharfun);
  2687                     --prstack.sp;
  2688                     --print_depth;
  2689                     goto next_obj;
  2690                   }
  2691 
  2692                 e->u.list.last = next;
  2693                 e->u.list.n--;
  2694                 if (e->u.list.n == 0)
  2695                   {
  2696                     /* Double tortoise update period and teleport it.  */
  2697                     e->u.list.tortoise_idx += e->u.list.m;
  2698                     e->u.list.m <<= 1;
  2699                     e->u.list.n = e->u.list.m;
  2700                     e->u.list.tortoise = next;
  2701                   }
  2702                 else if (BASE_EQ (next, e->u.list.tortoise))
  2703                   {
  2704                     /* FIXME: This #N tail index is somewhat ambiguous;
  2705                        see bug#55395.  */
  2706                     int len = sprintf (buf, ". #%" PRIdMAX ")",
  2707                                        e->u.list.tortoise_idx);
  2708                     strout (buf, len, len, printcharfun);
  2709                     --prstack.sp;
  2710                     --print_depth;
  2711                     goto next_obj;
  2712                   }
  2713                 obj = XCAR (next);
  2714               }
  2715             else
  2716               {
  2717                 /* non-nil ending: print " . " ELEM ")" */
  2718                 print_c_string (" . ", printcharfun);
  2719                 obj = next;
  2720                 e->type = PE_rbrac;
  2721               }
  2722             break;
  2723           }
  2724 
  2725         case PE_rbrac:
  2726           printchar (')', printcharfun);
  2727           --prstack.sp;
  2728           --print_depth;
  2729           goto next_obj;
  2730 
  2731         case PE_vector:
  2732           if (e->u.vector.idx >= e->u.vector.size)
  2733             {
  2734               if (e->u.vector.truncated)
  2735                 {
  2736                   if (e->u.vector.idx > 0)
  2737                     printchar (' ', printcharfun);
  2738                   print_c_string ("...", printcharfun);
  2739                 }
  2740               print_c_string (e->u.vector.end, printcharfun);
  2741               --prstack.sp;
  2742               --print_depth;
  2743               goto next_obj;
  2744             }
  2745           if (e->u.vector.idx > 0)
  2746             printchar (' ', printcharfun);
  2747           obj = AREF (e->u.vector.obj, e->u.vector.idx);
  2748           e->u.vector.idx++;
  2749           break;
  2750 
  2751         case PE_hash:
  2752           if (e->u.hash.printed >= e->u.hash.nobjs)
  2753             {
  2754               if (e->u.hash.truncated)
  2755                 {
  2756                   if (e->u.hash.printed)
  2757                     printchar (' ', printcharfun);
  2758                   print_c_string ("...", printcharfun);
  2759                 }
  2760               print_c_string ("))", printcharfun);
  2761               --prstack.sp;
  2762               --print_depth;
  2763               goto next_obj;
  2764             }
  2765 
  2766           if (e->u.hash.printed)
  2767             printchar (' ', printcharfun);
  2768 
  2769           struct Lisp_Hash_Table *h = XHASH_TABLE (e->u.hash.obj);
  2770           if ((e->u.hash.printed & 1) == 0)
  2771             {
  2772               Lisp_Object key;
  2773               ptrdiff_t idx = e->u.hash.idx;
  2774               while (BASE_EQ ((key = HASH_KEY (h, idx)), Qunbound))
  2775                 idx++;
  2776               e->u.hash.idx = idx;
  2777               obj = key;
  2778             }
  2779           else
  2780             {
  2781               obj = HASH_VALUE (h, e->u.hash.idx);
  2782               e->u.hash.idx++;
  2783             }
  2784           e->u.hash.printed++;
  2785           break;
  2786         }
  2787       goto print_obj;
  2788     }
  2789   eassert (print_depth == base_depth);
  2790 }
  2791 
  2792 
  2793 /* Print a description of INTERVAL using PRINTCHARFUN.
  2794    This is part of printing a string that has text properties.  */
  2795 
  2796 static void
  2797 print_interval (INTERVAL interval, Lisp_Object printcharfun)
  2798 {
  2799   if (NILP (interval->plist))
  2800     return;
  2801   printchar (' ', printcharfun);
  2802   print_object (make_fixnum (interval->position), printcharfun, 1);
  2803   printchar (' ', printcharfun);
  2804   print_object (make_fixnum (interval->position + LENGTH (interval)),
  2805                 printcharfun, 1);
  2806   printchar (' ', printcharfun);
  2807   print_object (interval->plist, printcharfun, 1);
  2808 }
  2809 
  2810 /* Initialize debug_print stuff early to have it working from the very
  2811    beginning.  */
  2812 
  2813 void
  2814 init_print_once (void)
  2815 {
  2816   /* The subroutine object for external-debugging-output is kept here
  2817      for the convenience of the debugger.  */
  2818   DEFSYM (Qexternal_debugging_output, "external-debugging-output");
  2819 
  2820   defsubr (&Sexternal_debugging_output);
  2821 }
  2822 
  2823 void
  2824 syms_of_print (void)
  2825 {
  2826   DEFSYM (Qtemp_buffer_setup_hook, "temp-buffer-setup-hook");
  2827 
  2828   DEFVAR_LISP ("standard-output", Vstandard_output,
  2829                doc: /* Output stream `print' uses by default for outputting a character.
  2830 This may be any function of one argument.
  2831 It may also be a buffer (output is inserted before point)
  2832 or a marker (output is inserted and the marker is advanced)
  2833 or the symbol t (output appears in the echo area).  */);
  2834   Vstandard_output = Qt;
  2835   DEFSYM (Qstandard_output, "standard-output");
  2836 
  2837   DEFVAR_LISP ("float-output-format", Vfloat_output_format,
  2838                doc: /* The format descriptor string used to print floats.
  2839 This is a %-spec like those accepted by `printf' in C,
  2840 but with some restrictions.  It must start with the two characters `%.'.
  2841 After that comes an integer precision specification,
  2842 and then a letter which controls the format.
  2843 The letters allowed are `e', `f' and `g'.
  2844 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
  2845 Use `f' for decimal point notation \"DIGITS.DIGITS\".
  2846 Use `g' to choose the shorter of those two formats for the number at hand.
  2847 The precision in any of these cases is the number of digits following
  2848 the decimal point.  With `f', a precision of 0 means to omit the
  2849 decimal point.  0 is not allowed with `e' or `g'.
  2850 
  2851 A value of nil means to use the shortest notation
  2852 that represents the number without losing information.  */);
  2853   Vfloat_output_format = Qnil;
  2854 
  2855   DEFVAR_BOOL ("print-integers-as-characters", print_integers_as_characters,
  2856                doc: /* Non-nil means integers are printed using characters syntax.
  2857 Only independent graphic characters, and control characters with named
  2858 escape sequences such as newline, are printed this way.  Other
  2859 integers, including those corresponding to raw bytes, are printed
  2860 as numbers the usual way.  */);
  2861   print_integers_as_characters = false;
  2862 
  2863   DEFVAR_LISP ("print-length", Vprint_length,
  2864                doc: /* Maximum length of list to print before abbreviating.
  2865 A value of nil means no limit.  See also `eval-expression-print-length'.  */);
  2866   Vprint_length = Qnil;
  2867 
  2868   DEFVAR_LISP ("print-level", Vprint_level,
  2869                doc: /* Maximum depth of list nesting to print before abbreviating.
  2870 A value of nil means no limit.  See also `eval-expression-print-level'.  */);
  2871   Vprint_level = Qnil;
  2872 
  2873   DEFVAR_BOOL ("print-escape-newlines", print_escape_newlines,
  2874                doc: /* Non-nil means print newlines in strings as `\\n'.
  2875 Also print formfeeds as `\\f'.  */);
  2876   print_escape_newlines = 0;
  2877 
  2878   DEFVAR_BOOL ("print-escape-control-characters", print_escape_control_characters,
  2879                doc: /* Non-nil means print control characters in strings as `\\OOO'.
  2880 \(OOO is the octal representation of the character code.)*/);
  2881   print_escape_control_characters = 0;
  2882 
  2883   DEFVAR_BOOL ("print-escape-nonascii", print_escape_nonascii,
  2884                doc: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
  2885 \(OOO is the octal representation of the character code.)
  2886 Only single-byte characters are affected, and only in `prin1'.
  2887 When the output goes in a multibyte buffer, this feature is
  2888 enabled regardless of the value of the variable.  */);
  2889   print_escape_nonascii = 0;
  2890 
  2891   DEFVAR_BOOL ("print-escape-multibyte", print_escape_multibyte,
  2892                doc: /* Non-nil means print multibyte characters in strings as \\xXXXX.
  2893 \(XXXX is the hex representation of the character code.)
  2894 This affects only `prin1'.  */);
  2895   print_escape_multibyte = 0;
  2896 
  2897   DEFVAR_BOOL ("print-quoted", print_quoted,
  2898                doc: /* Non-nil means print quoted forms with reader syntax.
  2899 I.e., (quote foo) prints as \\='foo, (function foo) as #\\='foo.  */);
  2900   print_quoted = true;
  2901 
  2902   DEFVAR_LISP ("print-gensym", Vprint_gensym,
  2903                doc: /* Non-nil means print uninterned symbols so they will read as uninterned.
  2904 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
  2905 When the uninterned symbol appears multiple times within the printed
  2906 expression, and `print-circle' is non-nil, in addition use the #N#
  2907 and #N= constructs as needed, so that multiple references to the same
  2908 symbol are shared once again when the text is read back.  */);
  2909   Vprint_gensym = Qnil;
  2910 
  2911   DEFVAR_LISP ("print-circle", Vprint_circle,
  2912                doc: /* Non-nil means print recursive structures using #N= and #N# syntax.
  2913 If nil, printing proceeds recursively and may lead to
  2914 `max-lisp-eval-depth' being exceeded or an error may occur:
  2915 \"Apparently circular structure being printed.\"  Also see
  2916 `print-length' and `print-level'.
  2917 If non-nil, shared substructures anywhere in the structure are printed
  2918 with `#N=' before the first occurrence (in the order of the print
  2919 representation) and `#N#' in place of each subsequent occurrence,
  2920 where N is a positive decimal integer.  */);
  2921   Vprint_circle = Qnil;
  2922 
  2923   DEFVAR_LISP ("print-continuous-numbering", Vprint_continuous_numbering,
  2924                doc: /* Non-nil means number continuously across print calls.
  2925 This affects the numbers printed for #N= labels and #M# references.
  2926 See also `print-circle', `print-gensym', and `print-number-table'.
  2927 This variable should not be set with `setq'; bind it with a `let' instead.  */);
  2928   Vprint_continuous_numbering = Qnil;
  2929 
  2930   DEFVAR_LISP ("print-number-table", Vprint_number_table,
  2931                doc: /* A vector used internally to produce `#N=' labels and `#N#' references.
  2932 The Lisp printer uses this vector to detect Lisp objects referenced more
  2933 than once.
  2934 
  2935 When you bind `print-continuous-numbering' to t, you should probably
  2936 also bind `print-number-table' to nil.  This ensures that the value of
  2937 `print-number-table' can be garbage-collected once the printing is
  2938 done.  If all elements of `print-number-table' are nil, it means that
  2939 the printing done so far has not found any shared structure or objects
  2940 that need to be recorded in the table.  */);
  2941   Vprint_number_table = Qnil;
  2942 
  2943   DEFVAR_LISP ("print-charset-text-property", Vprint_charset_text_property,
  2944                doc: /* A flag to control printing of `charset' text property on printing a string.
  2945 The value should be nil, t, or `default'.
  2946 
  2947 If the value is nil, don't print the text property `charset'.
  2948 
  2949 If the value is t, always print the text property `charset'.
  2950 
  2951 If the value is `default', print the text property `charset' only when
  2952 the value is different from what is guessed in the current charset
  2953 priorities.  Values other than nil or t are also treated as
  2954 `default'.  */);
  2955   Vprint_charset_text_property = Qdefault;
  2956 
  2957   DEFVAR_BOOL ("print-symbols-bare", print_symbols_bare,
  2958                doc: /* A flag to control printing of symbols with position.
  2959 If the value is nil, print these objects complete with position.
  2960 Otherwise print just the bare symbol.  */);
  2961   print_symbols_bare = false;
  2962   DEFSYM (Qprint_symbols_bare, "print-symbols-bare");
  2963 
  2964   /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
  2965   staticpro (&Vprin1_to_string_buffer);
  2966 
  2967   defsubr (&Sprin1);
  2968   defsubr (&Sprin1_to_string);
  2969   defsubr (&Serror_message_string);
  2970   defsubr (&Sprinc);
  2971   defsubr (&Sprint);
  2972   defsubr (&Sterpri);
  2973   defsubr (&Swrite_char);
  2974   defsubr (&Sredirect_debugging_output);
  2975   defsubr (&Sprint_preprocess);
  2976 
  2977   DEFSYM (Qprint_escape_multibyte, "print-escape-multibyte");
  2978   DEFSYM (Qprint_escape_nonascii, "print-escape-nonascii");
  2979 
  2980   print_prune_charset_plist = Qnil;
  2981   staticpro (&print_prune_charset_plist);
  2982 
  2983   DEFVAR_LISP ("print-unreadable-function", Vprint_unreadable_function,
  2984                doc: /* If non-nil, a function to call when printing unreadable objects.
  2985 By default, Emacs printing functions (like `prin1') print unreadable
  2986 objects as \"#<...>\", where \"...\" describes the object (for
  2987 instance, \"#<marker in no buffer>\").
  2988 
  2989 If non-nil, it should be a function that will be called with two
  2990 arguments: the object to be printed, and the NOESCAPE flag (see
  2991 `prin1-to-string').  If this function returns nil, the object will be
  2992 printed as usual.  If it returns a string, that string will then be
  2993 printed.  If the function returns anything else, the object will not
  2994 be printed.  */);
  2995   Vprint_unreadable_function = Qnil;
  2996   DEFSYM (Qprint_unreadable_function, "print-unreadable-function");
  2997 
  2998   DEFVAR_LISP ("print--unreadable-callback-buffer",
  2999                Vprint__unreadable_callback_buffer,
  3000                doc: /* Dynamically bound to indicate current buffer.  */);
  3001   Vprint__unreadable_callback_buffer = Qnil;
  3002   DEFSYM (Qprint__unreadable_callback_buffer,
  3003           "print--unreadable-callback-buffer");
  3004   /* Don't export this variable to Elisp.  */
  3005   Funintern (Qprint__unreadable_callback_buffer, Qnil);
  3006 
  3007   defsubr (&Sflush_standard_output);
  3008 
  3009   /* Initialized in print_create_variable_mapping.  */
  3010   staticpro (&Vprint_variable_mapping);
  3011 }