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                 printchar (' ', printcharfun);
  1916                 if (i < FONT_WEIGHT_INDEX || i > FONT_WIDTH_INDEX)
  1917                   print_object (AREF (obj, i), printcharfun, escapeflag);
  1918                 else
  1919                   print_object (font_style_symbolic (obj, i, 0),
  1920                                 printcharfun, escapeflag);
  1921               }
  1922           }
  1923         else
  1924           {
  1925             print_c_string ("#<font-object ", printcharfun);
  1926             print_object (AREF (obj, FONT_NAME_INDEX), printcharfun,
  1927                           escapeflag);
  1928           }
  1929         printchar ('>', printcharfun);
  1930       }
  1931       break;
  1932 
  1933     case PVEC_THREAD:
  1934       print_c_string ("#<thread ", printcharfun);
  1935       if (STRINGP (XTHREAD (obj)->name))
  1936         print_string (XTHREAD (obj)->name, printcharfun);
  1937       else
  1938         {
  1939           void *p = XTHREAD (obj);
  1940           int len = sprintf (buf, "%p", p);
  1941           strout (buf, len, len, printcharfun);
  1942         }
  1943       printchar ('>', printcharfun);
  1944       break;
  1945 
  1946     case PVEC_MUTEX:
  1947       print_c_string ("#<mutex ", printcharfun);
  1948       if (STRINGP (XMUTEX (obj)->name))
  1949         print_string (XMUTEX (obj)->name, printcharfun);
  1950       else
  1951         {
  1952           void *p = XMUTEX (obj);
  1953           int len = sprintf (buf, "%p", p);
  1954           strout (buf, len, len, printcharfun);
  1955         }
  1956       printchar ('>', printcharfun);
  1957       break;
  1958 
  1959     case PVEC_CONDVAR:
  1960       print_c_string ("#<condvar ", printcharfun);
  1961       if (STRINGP (XCONDVAR (obj)->name))
  1962         print_string (XCONDVAR (obj)->name, printcharfun);
  1963       else
  1964         {
  1965           void *p = XCONDVAR (obj);
  1966           int len = sprintf (buf, "%p", p);
  1967           strout (buf, len, len, printcharfun);
  1968         }
  1969       printchar ('>', printcharfun);
  1970       break;
  1971 
  1972 #ifdef HAVE_MODULES
  1973     case PVEC_MODULE_FUNCTION:
  1974       {
  1975         print_c_string ("#<module function ", printcharfun);
  1976         const struct Lisp_Module_Function *function = XMODULE_FUNCTION (obj);
  1977         module_funcptr ptr = module_function_address (function);
  1978         char const *file;
  1979         char const *symbol;
  1980         dynlib_addr (ptr, &file, &symbol);
  1981 
  1982         if (symbol == NULL)
  1983           print_pointer (printcharfun, buf, "at", data_from_funcptr (ptr));
  1984         else
  1985           print_c_string (symbol, printcharfun);
  1986 
  1987         void *data = module_function_data (function);
  1988         if (data != NULL)
  1989           print_pointer (printcharfun, buf, " with data", data);
  1990 
  1991         if (file != NULL)
  1992           {
  1993             print_c_string (" from ", printcharfun);
  1994             print_c_string (file, printcharfun);
  1995           }
  1996 
  1997         printchar ('>', printcharfun);
  1998       }
  1999       break;
  2000 #endif
  2001 #ifdef HAVE_NATIVE_COMP
  2002     case PVEC_NATIVE_COMP_UNIT:
  2003       {
  2004         struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (obj);
  2005         print_c_string ("#<native compilation unit: ", printcharfun);
  2006         print_string (cu->file, printcharfun);
  2007         printchar (' ', printcharfun);
  2008         print_object (cu->optimize_qualities, printcharfun, escapeflag);
  2009         printchar ('>', printcharfun);
  2010       }
  2011       break;
  2012 #endif
  2013 
  2014 #ifdef HAVE_TREE_SITTER
  2015     case PVEC_TS_PARSER:
  2016       print_c_string ("#<treesit-parser for ", printcharfun);
  2017       Lisp_Object language = XTS_PARSER (obj)->language_symbol;
  2018       /* No need to print the buffer because it's not that useful: we
  2019          usually know which buffer a parser belongs to.  */
  2020       print_string (Fsymbol_name (language), printcharfun);
  2021       printchar ('>', printcharfun);
  2022       break;
  2023     case PVEC_TS_NODE:
  2024       /* Prints #<treesit-node (identifier) in 12-15> or
  2025          #<treesit-node "keyword" in 28-31>. */
  2026       print_c_string ("#<treesit-node", printcharfun);
  2027       if (!treesit_node_uptodate_p (obj))
  2028         {
  2029           print_c_string ("-outdated>", printcharfun);
  2030           break;
  2031         }
  2032       printchar (' ', printcharfun);
  2033       /* Now the node must be up-to-date, and calling functions like
  2034          Ftreesit_node_start will not signal.  */
  2035       bool named = treesit_named_node_p (XTS_NODE (obj)->node);
  2036       /* We used to use () as delimiters for named nodes, but that
  2037          confuses pretty-printing a tad bit.  There might be more
  2038          little breakages here and there if we print parenthesizes
  2039          inside an object, so I guess better not do it.
  2040          (bug#60696)  */
  2041       const char *delim1 = named ? "" : "\"";
  2042       const char *delim2 = named ? "" : "\"";
  2043       print_c_string (delim1, printcharfun);
  2044       print_string (Ftreesit_node_type (obj), printcharfun);
  2045       print_c_string (delim2, printcharfun);
  2046       print_c_string (" in ", printcharfun);
  2047       print_object (Ftreesit_node_start (obj), printcharfun, escapeflag);
  2048       printchar ('-', printcharfun);
  2049       print_object (Ftreesit_node_end (obj), printcharfun, escapeflag);
  2050       printchar ('>', printcharfun);
  2051       break;
  2052     case PVEC_TS_COMPILED_QUERY:
  2053       print_c_string ("#<treesit-compiled-query>", printcharfun);
  2054       break;
  2055 #endif
  2056 
  2057     case PVEC_SQLITE:
  2058       {
  2059         print_c_string ("#<sqlite ", printcharfun);
  2060         int i = sprintf (buf, "db=%p", XSQLITE (obj)->db);
  2061         strout (buf, i, i, printcharfun);
  2062         if (XSQLITE (obj)->is_statement)
  2063           {
  2064             i = sprintf (buf, " stmt=%p", XSQLITE (obj)->stmt);
  2065             strout (buf, i, i, printcharfun);
  2066           }
  2067         print_c_string (" name=", printcharfun);
  2068         print_c_string (XSQLITE (obj)->name, printcharfun);
  2069         printchar ('>', printcharfun);
  2070       }
  2071       break;
  2072 
  2073     default:
  2074       emacs_abort ();
  2075     }
  2076 
  2077   return true;
  2078 }
  2079 
  2080 static char
  2081 named_escape (int i)
  2082 {
  2083   switch (i)
  2084     {
  2085     case '\b': return 'b';
  2086     case '\t': return 't';
  2087     case '\n': return 'n';
  2088     case '\f': return 'f';
  2089     case '\r': return 'r';
  2090     case ' ':  return 's';
  2091       /* \a, \v, \e and \d are excluded from printing as escapes since
  2092          they are somewhat rare as characters and more likely to be
  2093          plain integers. */
  2094     }
  2095   return 0;
  2096 }
  2097 
  2098 enum print_entry_type
  2099   {
  2100     PE_list,                    /* print rest of list */
  2101     PE_rbrac,                   /* print ")" */
  2102     PE_vector,                  /* print rest of vector */
  2103     PE_hash,                    /* print rest of hash data */
  2104   };
  2105 
  2106 struct print_stack_entry
  2107 {
  2108   enum print_entry_type type;
  2109 
  2110   union
  2111   {
  2112     struct
  2113     {
  2114       Lisp_Object last;         /* cons whose car was just printed  */
  2115       intmax_t maxlen;          /* max number of elements left to print */
  2116       /* State for Brent cycle detection.  See
  2117          Brent RP. BIT. 1980;20(2):176-184. doi:10.1007/BF01933190
  2118          https://maths-people.anu.edu.au/~brent/pd/rpb051i.pdf */
  2119       Lisp_Object tortoise;     /* slow pointer */
  2120       ptrdiff_t n;              /* tortoise step countdown */
  2121       ptrdiff_t m;              /* tortoise step period */
  2122       intmax_t tortoise_idx;    /* index of tortoise */
  2123     } list;
  2124 
  2125     struct
  2126     {
  2127       Lisp_Object obj;          /* object to print after " . " */
  2128     } dotted_cdr;
  2129 
  2130     struct
  2131     {
  2132       Lisp_Object obj;          /* vector object */
  2133       ptrdiff_t size;           /* length of vector */
  2134       ptrdiff_t idx;            /* index of next element */
  2135       const char *end;          /* string to print at end */
  2136       bool truncated;           /* whether to print "..." before end */
  2137     } vector;
  2138 
  2139     struct
  2140     {
  2141       Lisp_Object obj;          /* hash-table object */
  2142       ptrdiff_t nobjs;          /* number of keys and values to print */
  2143       ptrdiff_t idx;            /* index of key-value pair */
  2144       ptrdiff_t printed;        /* number of keys and values printed */
  2145       bool truncated;           /* whether to print "..." before end */
  2146     } hash;
  2147   } u;
  2148 };
  2149 
  2150 struct print_stack
  2151 {
  2152   struct print_stack_entry *stack;  /* base of stack */
  2153   ptrdiff_t size;                   /* allocated size in entries */
  2154   ptrdiff_t sp;                     /* current number of entries */
  2155 };
  2156 
  2157 static struct print_stack prstack = {NULL, 0, 0};
  2158 
  2159 NO_INLINE static void
  2160 grow_print_stack (void)
  2161 {
  2162   struct print_stack *ps = &prstack;
  2163   eassert (ps->sp == ps->size);
  2164   ps->stack = xpalloc (ps->stack, &ps->size, 1, -1, sizeof *ps->stack);
  2165   eassert (ps->sp < ps->size);
  2166 }
  2167 
  2168 static inline void
  2169 print_stack_push (struct print_stack_entry e)
  2170 {
  2171   if (prstack.sp >= prstack.size)
  2172     grow_print_stack ();
  2173   prstack.stack[prstack.sp++] = e;
  2174 }
  2175 
  2176 static void
  2177 print_stack_push_vector (const char *lbrac, const char *rbrac,
  2178                          Lisp_Object obj, ptrdiff_t start, ptrdiff_t size,
  2179                          Lisp_Object printcharfun)
  2180 {
  2181   print_c_string (lbrac, printcharfun);
  2182 
  2183   ptrdiff_t print_size = ((FIXNATP (Vprint_length)
  2184                            && XFIXNAT (Vprint_length) < size)
  2185                           ? XFIXNAT (Vprint_length) : size);
  2186   print_stack_push ((struct print_stack_entry){
  2187       .type = PE_vector,
  2188       .u.vector.obj = obj,
  2189       .u.vector.size = print_size,
  2190       .u.vector.idx = start,
  2191       .u.vector.end = rbrac,
  2192       .u.vector.truncated = (print_size < size),
  2193     });
  2194 }
  2195 
  2196 static void
  2197 print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
  2198 {
  2199   ptrdiff_t base_depth = print_depth;
  2200   ptrdiff_t base_sp = prstack.sp;
  2201   char buf[max (sizeof "from..to..in " + 2 * INT_STRLEN_BOUND (EMACS_INT),
  2202                 max (sizeof " . #" + INT_STRLEN_BOUND (intmax_t),
  2203                      max ((sizeof " with data 0x"
  2204                            + (sizeof (uintmax_t) * CHAR_BIT + 4 - 1) / 4),
  2205                           40)))];
  2206   current_thread->stack_top = buf;
  2207 
  2208  print_obj:
  2209   maybe_quit ();
  2210 
  2211   /* Detect circularities and truncate them.  */
  2212   if (NILP (Vprint_circle))
  2213     {
  2214       /* Simple but incomplete way.  */
  2215       if (print_depth >= PRINT_CIRCLE)
  2216         error ("Apparently circular structure being printed");
  2217 
  2218       for (int i = 0; i < print_depth; i++)
  2219         if (BASE_EQ (obj, being_printed[i]))
  2220           {
  2221             int len = sprintf (buf, "#%d", i);
  2222             strout (buf, len, len, printcharfun);
  2223             goto next_obj;
  2224           }
  2225       being_printed[print_depth] = obj;
  2226     }
  2227   else if (PRINT_CIRCLE_CANDIDATE_P (obj))
  2228     {
  2229       /* With the print-circle feature.  */
  2230       Lisp_Object num = Fgethash (obj, Vprint_number_table, Qnil);
  2231       if (FIXNUMP (num))
  2232         {
  2233           EMACS_INT n = XFIXNUM (num);
  2234           if (n < 0)
  2235             { /* Add a prefix #n= if OBJ has not yet been printed;
  2236                  that is, its status field is nil.  */
  2237               int len = sprintf (buf, "#%"pI"d=", -n);
  2238               strout (buf, len, len, printcharfun);
  2239               /* OBJ is going to be printed.  Remember that fact.  */
  2240               Fputhash (obj, make_fixnum (- n), Vprint_number_table);
  2241             }
  2242           else
  2243             {
  2244               /* Just print #n# if OBJ has already been printed.  */
  2245               int len = sprintf (buf, "#%"pI"d#", n);
  2246               strout (buf, len, len, printcharfun);
  2247               goto next_obj;
  2248             }
  2249         }
  2250     }
  2251 
  2252   print_depth++;
  2253 
  2254   switch (XTYPE (obj))
  2255     {
  2256     case_Lisp_Int:
  2257       {
  2258         EMACS_INT i = XFIXNUM (obj);
  2259         char escaped_name;
  2260 
  2261         if (print_integers_as_characters && i >= 0 && i <= MAX_UNICODE_CHAR
  2262             && ((escaped_name = named_escape (i))
  2263                 || graphic_base_p (i)))
  2264           {
  2265             printchar ('?', printcharfun);
  2266             if (escaped_name)
  2267               {
  2268                 printchar ('\\', printcharfun);
  2269                 i = escaped_name;
  2270               }
  2271             else if (escapeflag
  2272                      && (i == ';' || i == '\"' || i == '\'' || i == '\\'
  2273                          || i == '(' || i == ')'
  2274                          || i == '{' || i == '}'
  2275                          || i == '[' || i == ']'))
  2276               printchar ('\\', printcharfun);
  2277             printchar (i, printcharfun);
  2278           }
  2279         else
  2280           {
  2281             char *end = buf + sizeof buf;
  2282             char *start = fixnum_to_string (i, buf, end);
  2283             ptrdiff_t len = end - start;
  2284             strout (start, len, len, printcharfun);
  2285           }
  2286       }
  2287       break;
  2288 
  2289     case Lisp_Float:
  2290       {
  2291         char pigbuf[FLOAT_TO_STRING_BUFSIZE];
  2292         int len = float_to_string (pigbuf, XFLOAT_DATA (obj));
  2293         strout (pigbuf, len, len, printcharfun);
  2294       }
  2295       break;
  2296 
  2297     case Lisp_String:
  2298       if (!escapeflag)
  2299         print_string (obj, printcharfun);
  2300       else
  2301         {
  2302           ptrdiff_t i, i_byte;
  2303           ptrdiff_t size_byte;
  2304           /* True means we must ensure that the next character we output
  2305              cannot be taken as part of a hex character escape.  */
  2306           bool need_nonhex = false;
  2307           bool multibyte = STRING_MULTIBYTE (obj);
  2308 
  2309           if (! EQ (Vprint_charset_text_property, Qt))
  2310             obj = print_prune_string_charset (obj);
  2311 
  2312           if (string_intervals (obj))
  2313             print_c_string ("#(", printcharfun);
  2314 
  2315           printchar ('\"', printcharfun);
  2316           size_byte = SBYTES (obj);
  2317 
  2318           for (i = 0, i_byte = 0; i_byte < size_byte;)
  2319             {
  2320               /* Here, we must convert each multi-byte form to the
  2321                  corresponding character code before handing it to
  2322                  printchar.  */
  2323               int c = fetch_string_char_advance (obj, &i, &i_byte);
  2324 
  2325               maybe_quit ();
  2326 
  2327               if (multibyte
  2328                   ? (CHAR_BYTE8_P (c) && (c = CHAR_TO_BYTE8 (c), true))
  2329                   : (SINGLE_BYTE_CHAR_P (c) && ! ASCII_CHAR_P (c)
  2330                      && print_escape_nonascii))
  2331                 {
  2332                   /* When printing a raw 8-bit byte in a multibyte buffer, or
  2333                      (when requested) a non-ASCII character in a unibyte buffer,
  2334                      print single-byte non-ASCII string chars
  2335                      using octal escapes.  */
  2336                   octalout (c, SDATA (obj), i_byte, size_byte, printcharfun);
  2337                   need_nonhex = false;
  2338                 }
  2339               else if (multibyte
  2340                        && ! ASCII_CHAR_P (c) && print_escape_multibyte)
  2341                 {
  2342                   /* When requested, print multibyte chars using
  2343                      hex escapes.  */
  2344                   char outbuf[sizeof "\\x" + INT_STRLEN_BOUND (c)];
  2345                   int len = sprintf (outbuf, "\\x%04x", c + 0u);
  2346                   strout (outbuf, len, len, printcharfun);
  2347                   need_nonhex = true;
  2348                 }
  2349               else
  2350                 {
  2351                   /* If we just had a hex escape, and this character
  2352                      could be taken as part of it,
  2353                      output `\ ' to prevent that.  */
  2354                   if (c_isxdigit (c))
  2355                     {
  2356                       if (need_nonhex)
  2357                         print_c_string ("\\ ", printcharfun);
  2358                       printchar (c, printcharfun);
  2359                     }
  2360                   else if (c == '\n' && print_escape_newlines
  2361                            ? (c = 'n', true)
  2362                            : c == '\f' && print_escape_newlines
  2363                            ? (c = 'f', true)
  2364                            : c == '\"' || c == '\\')
  2365                     {
  2366                       printchar ('\\', printcharfun);
  2367                       printchar (c, printcharfun);
  2368                     }
  2369                   else if (print_escape_control_characters && c_iscntrl (c))
  2370                     octalout (c, SDATA (obj), i_byte, size_byte, printcharfun);
  2371                   else if (!multibyte
  2372                            && SINGLE_BYTE_CHAR_P (c)
  2373                            && !ASCII_CHAR_P (c))
  2374                     printchar (BYTE8_TO_CHAR (c), printcharfun);
  2375                   else
  2376                     printchar (c, printcharfun);
  2377                   need_nonhex = false;
  2378                 }
  2379             }
  2380           printchar ('\"', printcharfun);
  2381 
  2382           if (string_intervals (obj))
  2383             {
  2384               traverse_intervals (string_intervals (obj),
  2385                                   0, print_interval, printcharfun);
  2386               printchar (')', printcharfun);
  2387             }
  2388         }
  2389       break;
  2390 
  2391     case Lisp_Symbol:
  2392       {
  2393         Lisp_Object name = SYMBOL_NAME (obj);
  2394         ptrdiff_t size_byte = SBYTES (name);
  2395 
  2396         char *p = SSDATA (name);
  2397         bool signedp = *p == '-' || *p == '+';
  2398         ptrdiff_t len;
  2399         bool confusing =
  2400           /* Set CONFUSING if NAME looks like a number, calling
  2401              string_to_number for non-obvious cases.  */
  2402           ((c_isdigit (p[signedp]) || p[signedp] == '.')
  2403            && !NILP (string_to_number (p, 10, &len))
  2404            && len == size_byte)
  2405           /* We don't escape "." or "?" (unless they're the first
  2406              character in the symbol name).  */
  2407           || *p == '?'
  2408           || *p == '.';
  2409 
  2410         if (! NILP (Vprint_gensym)
  2411             && !SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (obj))
  2412           print_c_string ("#:", printcharfun);
  2413         else if (size_byte == 0)
  2414           {
  2415             print_c_string ("##", printcharfun);
  2416             break;
  2417           }
  2418 
  2419         ptrdiff_t i = 0;
  2420         for (ptrdiff_t i_byte = 0; i_byte < size_byte; )
  2421           {
  2422             /* Here, we must convert each multi-byte form to the
  2423                corresponding character code before handing it to PRINTCHAR.  */
  2424             int c = fetch_string_char_advance (name, &i, &i_byte);
  2425             maybe_quit ();
  2426 
  2427             if (escapeflag)
  2428               {
  2429                 if (c == '\"' || c == '\\' || c == '\''
  2430                     || c == ';' || c == '#' || c == '(' || c == ')'
  2431                     || c == ',' || c == '`'
  2432                     || c == '[' || c == ']' || c <= 040
  2433                     || c == NO_BREAK_SPACE
  2434                     || confusing)
  2435                   {
  2436                     printchar ('\\', printcharfun);
  2437                     confusing = false;
  2438                   }
  2439               }
  2440             printchar (c, printcharfun);
  2441           }
  2442       }
  2443       break;
  2444 
  2445     case Lisp_Cons:
  2446       /* If deeper than spec'd depth, print placeholder.  */
  2447       if (FIXNUMP (Vprint_level)
  2448           && print_depth > XFIXNUM (Vprint_level))
  2449         print_c_string ("...", printcharfun);
  2450       else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
  2451                && EQ (XCAR (obj), Qquote))
  2452         {
  2453           printchar ('\'', printcharfun);
  2454           obj = XCAR (XCDR (obj));
  2455           --print_depth;        /* tail recursion */
  2456           goto print_obj;
  2457         }
  2458       else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
  2459                && EQ (XCAR (obj), Qfunction))
  2460         {
  2461           print_c_string ("#'", printcharfun);
  2462           obj = XCAR (XCDR (obj));
  2463           --print_depth;        /* tail recursion */
  2464           goto print_obj;
  2465         }
  2466       /* FIXME: Do we really need the new_backquote_output gating of
  2467          special syntax for comma and comma-at?  There is basically no
  2468          benefit from it at all, and it would be nice to get rid of
  2469          the recursion here without additional complexity.  */
  2470       else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
  2471                && EQ (XCAR (obj), Qbackquote))
  2472         {
  2473           printchar ('`', printcharfun);
  2474           new_backquote_output++;
  2475           print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
  2476           new_backquote_output--;
  2477         }
  2478       else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
  2479                && (EQ (XCAR (obj), Qcomma)
  2480                    || EQ (XCAR (obj), Qcomma_at))
  2481                && new_backquote_output)
  2482         {
  2483           print_object (XCAR (obj), printcharfun, false);
  2484           new_backquote_output--;
  2485           print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
  2486           new_backquote_output++;
  2487         }
  2488       else
  2489         {
  2490           printchar ('(', printcharfun);
  2491           /* Negative values of print-length are invalid in CL.
  2492              Treat them like nil, as CMUCL does.  */
  2493           intmax_t print_length = (FIXNATP (Vprint_length)
  2494                                    ? XFIXNAT (Vprint_length)
  2495                                    : INTMAX_MAX);
  2496           if (print_length == 0)
  2497             print_c_string ("...)", printcharfun);
  2498           else
  2499             {
  2500               print_stack_push ((struct print_stack_entry){
  2501                   .type = PE_list,
  2502                   .u.list.last = obj,
  2503                   .u.list.maxlen = print_length,
  2504                   .u.list.tortoise = obj,
  2505                   .u.list.n = 2,
  2506                   .u.list.m = 2,
  2507                   .u.list.tortoise_idx = 0,
  2508                 });
  2509               /* print the car */
  2510               obj = XCAR (obj);
  2511               goto print_obj;
  2512             }
  2513         }
  2514       break;
  2515 
  2516     case Lisp_Vectorlike:
  2517       /* First do all the vectorlike types that have a readable syntax.  */
  2518       switch (PSEUDOVECTOR_TYPE (XVECTOR (obj)))
  2519         {
  2520         case PVEC_NORMAL_VECTOR:
  2521           {
  2522             print_stack_push_vector ("[", "]", obj, 0, ASIZE (obj),
  2523                                      printcharfun);
  2524             goto next_obj;
  2525           }
  2526         case PVEC_RECORD:
  2527           {
  2528             print_stack_push_vector ("#s(", ")", obj, 0, PVSIZE (obj),
  2529                                      printcharfun);
  2530             goto next_obj;
  2531           }
  2532         case PVEC_COMPILED:
  2533           {
  2534             print_stack_push_vector ("#[", "]", obj, 0, PVSIZE (obj),
  2535                                      printcharfun);
  2536             goto next_obj;
  2537           }
  2538         case PVEC_CHAR_TABLE:
  2539           {
  2540             print_stack_push_vector ("#^[", "]", obj, 0, PVSIZE (obj),
  2541                                      printcharfun);
  2542             goto next_obj;
  2543           }
  2544         case PVEC_SUB_CHAR_TABLE:
  2545           {
  2546             /* Make each lowest sub_char_table start a new line.
  2547                Otherwise we'll make a line extremely long, which
  2548                results in slow redisplay.  */
  2549             if (XSUB_CHAR_TABLE (obj)->depth == 3)
  2550               printchar ('\n', printcharfun);
  2551             print_c_string ("#^^[", printcharfun);
  2552             int n = sprintf (buf, "%d %d",
  2553                              XSUB_CHAR_TABLE (obj)->depth,
  2554                              XSUB_CHAR_TABLE (obj)->min_char);
  2555             strout (buf, n, n, printcharfun);
  2556             print_stack_push_vector ("", "]", obj,
  2557                                      SUB_CHAR_TABLE_OFFSET, PVSIZE (obj),
  2558                                      printcharfun);
  2559             goto next_obj;
  2560           }
  2561         case PVEC_HASH_TABLE:
  2562           {
  2563             struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
  2564             /* Implement a readable output, e.g.:
  2565                #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
  2566             /* Always print the size.  */
  2567             int len = sprintf (buf, "#s(hash-table size %"pD"d",
  2568                                HASH_TABLE_SIZE (h));
  2569             strout (buf, len, len, printcharfun);
  2570 
  2571             if (!NILP (h->test.name))
  2572               {
  2573                 print_c_string (" test ", printcharfun);
  2574                 print_object (h->test.name, printcharfun, escapeflag);
  2575               }
  2576 
  2577             if (!NILP (h->weak))
  2578               {
  2579                 print_c_string (" weakness ", printcharfun);
  2580                 print_object (h->weak, printcharfun, escapeflag);
  2581               }
  2582 
  2583             print_c_string (" rehash-size ", printcharfun);
  2584             print_object (Fhash_table_rehash_size (obj),
  2585                           printcharfun, escapeflag);
  2586 
  2587             print_c_string (" rehash-threshold ", printcharfun);
  2588             print_object (Fhash_table_rehash_threshold (obj),
  2589                           printcharfun, escapeflag);
  2590 
  2591             if (h->purecopy)
  2592               print_c_string (" purecopy t", printcharfun);
  2593 
  2594             print_c_string (" data (", printcharfun);
  2595 
  2596             ptrdiff_t size = h->count;
  2597             /* Don't print more elements than the specified maximum.  */
  2598             if (FIXNATP (Vprint_length) && XFIXNAT (Vprint_length) < size)
  2599               size = XFIXNAT (Vprint_length);
  2600 
  2601             print_stack_push ((struct print_stack_entry){
  2602                 .type = PE_hash,
  2603                 .u.hash.obj = obj,
  2604                 .u.hash.nobjs = size * 2,
  2605                 .u.hash.idx = 0,
  2606                 .u.hash.printed = 0,
  2607                 .u.hash.truncated = (size < h->count),
  2608               });
  2609             goto next_obj;
  2610           }
  2611 
  2612         default:
  2613           break;
  2614         }
  2615 
  2616       if (print_vectorlike (obj, printcharfun, escapeflag, buf))
  2617         break;
  2618       FALLTHROUGH;
  2619 
  2620     default:
  2621       {
  2622         int len;
  2623         /* We're in trouble if this happens!
  2624            Probably should just emacs_abort ().  */
  2625         print_c_string ("#<EMACS BUG: INVALID DATATYPE ", printcharfun);
  2626         if (VECTORLIKEP (obj))
  2627           len = sprintf (buf, "(PVEC 0x%08zx)", (size_t) ASIZE (obj));
  2628         else
  2629           len = sprintf (buf, "(0x%02x)", (unsigned) XTYPE (obj));
  2630         strout (buf, len, len, printcharfun);
  2631         print_c_string ((" Save your buffers immediately"
  2632                          " and please report this bug>"),
  2633                         printcharfun);
  2634         break;
  2635       }
  2636     }
  2637   print_depth--;
  2638 
  2639  next_obj:
  2640   if (prstack.sp > base_sp)
  2641     {
  2642       /* Handle a continuation on the print stack.  */
  2643       struct print_stack_entry *e = &prstack.stack[prstack.sp - 1];
  2644       switch (e->type)
  2645         {
  2646         case PE_list:
  2647           {
  2648             /* after "(" ELEM (* " " ELEM) */
  2649             Lisp_Object next = XCDR (e->u.list.last);
  2650             if (NILP (next))
  2651               {
  2652                 /* end of list: print ")" */
  2653                 printchar (')', printcharfun);
  2654                 --prstack.sp;
  2655                 --print_depth;
  2656                 goto next_obj;
  2657               }
  2658             else if (CONSP (next))
  2659               {
  2660                 if (!NILP (Vprint_circle))
  2661                   {
  2662                     /* With the print-circle feature.  */
  2663                     Lisp_Object num = Fgethash (next, Vprint_number_table,
  2664                                                 Qnil);
  2665                     if (FIXNUMP (num))
  2666                       {
  2667                         print_c_string (" . ", printcharfun);
  2668                         obj = next;
  2669                         e->type = PE_rbrac;
  2670                         goto print_obj;
  2671                       }
  2672                   }
  2673 
  2674                 /* list continues: print " " ELEM ... */
  2675 
  2676                 printchar (' ', printcharfun);
  2677 
  2678                 --e->u.list.maxlen;
  2679                 if (e->u.list.maxlen <= 0)
  2680                   {
  2681                     print_c_string ("...)", printcharfun);
  2682                     --prstack.sp;
  2683                     --print_depth;
  2684                     goto next_obj;
  2685                   }
  2686 
  2687                 e->u.list.last = next;
  2688                 e->u.list.n--;
  2689                 if (e->u.list.n == 0)
  2690                   {
  2691                     /* Double tortoise update period and teleport it.  */
  2692                     e->u.list.tortoise_idx += e->u.list.m;
  2693                     e->u.list.m <<= 1;
  2694                     e->u.list.n = e->u.list.m;
  2695                     e->u.list.tortoise = next;
  2696                   }
  2697                 else if (BASE_EQ (next, e->u.list.tortoise))
  2698                   {
  2699                     /* FIXME: This #N tail index is somewhat ambiguous;
  2700                        see bug#55395.  */
  2701                     int len = sprintf (buf, ". #%" PRIdMAX ")",
  2702                                        e->u.list.tortoise_idx);
  2703                     strout (buf, len, len, printcharfun);
  2704                     --prstack.sp;
  2705                     --print_depth;
  2706                     goto next_obj;
  2707                   }
  2708                 obj = XCAR (next);
  2709               }
  2710             else
  2711               {
  2712                 /* non-nil ending: print " . " ELEM ")" */
  2713                 print_c_string (" . ", printcharfun);
  2714                 obj = next;
  2715                 e->type = PE_rbrac;
  2716               }
  2717             break;
  2718           }
  2719 
  2720         case PE_rbrac:
  2721           printchar (')', printcharfun);
  2722           --prstack.sp;
  2723           --print_depth;
  2724           goto next_obj;
  2725 
  2726         case PE_vector:
  2727           if (e->u.vector.idx >= e->u.vector.size)
  2728             {
  2729               if (e->u.vector.truncated)
  2730                 {
  2731                   if (e->u.vector.idx > 0)
  2732                     printchar (' ', printcharfun);
  2733                   print_c_string ("...", printcharfun);
  2734                 }
  2735               print_c_string (e->u.vector.end, printcharfun);
  2736               --prstack.sp;
  2737               --print_depth;
  2738               goto next_obj;
  2739             }
  2740           if (e->u.vector.idx > 0)
  2741             printchar (' ', printcharfun);
  2742           obj = AREF (e->u.vector.obj, e->u.vector.idx);
  2743           e->u.vector.idx++;
  2744           break;
  2745 
  2746         case PE_hash:
  2747           if (e->u.hash.printed >= e->u.hash.nobjs)
  2748             {
  2749               if (e->u.hash.truncated)
  2750                 {
  2751                   if (e->u.hash.printed)
  2752                     printchar (' ', printcharfun);
  2753                   print_c_string ("...", printcharfun);
  2754                 }
  2755               print_c_string ("))", printcharfun);
  2756               --prstack.sp;
  2757               --print_depth;
  2758               goto next_obj;
  2759             }
  2760 
  2761           if (e->u.hash.printed)
  2762             printchar (' ', printcharfun);
  2763 
  2764           struct Lisp_Hash_Table *h = XHASH_TABLE (e->u.hash.obj);
  2765           if ((e->u.hash.printed & 1) == 0)
  2766             {
  2767               Lisp_Object key;
  2768               ptrdiff_t idx = e->u.hash.idx;
  2769               while (BASE_EQ ((key = HASH_KEY (h, idx)), Qunbound))
  2770                 idx++;
  2771               e->u.hash.idx = idx;
  2772               obj = key;
  2773             }
  2774           else
  2775             {
  2776               obj = HASH_VALUE (h, e->u.hash.idx);
  2777               e->u.hash.idx++;
  2778             }
  2779           e->u.hash.printed++;
  2780           break;
  2781         }
  2782       goto print_obj;
  2783     }
  2784   eassert (print_depth == base_depth);
  2785 }
  2786 
  2787 
  2788 /* Print a description of INTERVAL using PRINTCHARFUN.
  2789    This is part of printing a string that has text properties.  */
  2790 
  2791 static void
  2792 print_interval (INTERVAL interval, Lisp_Object printcharfun)
  2793 {
  2794   if (NILP (interval->plist))
  2795     return;
  2796   printchar (' ', printcharfun);
  2797   print_object (make_fixnum (interval->position), printcharfun, 1);
  2798   printchar (' ', printcharfun);
  2799   print_object (make_fixnum (interval->position + LENGTH (interval)),
  2800                 printcharfun, 1);
  2801   printchar (' ', printcharfun);
  2802   print_object (interval->plist, printcharfun, 1);
  2803 }
  2804 
  2805 /* Initialize debug_print stuff early to have it working from the very
  2806    beginning.  */
  2807 
  2808 void
  2809 init_print_once (void)
  2810 {
  2811   /* The subroutine object for external-debugging-output is kept here
  2812      for the convenience of the debugger.  */
  2813   DEFSYM (Qexternal_debugging_output, "external-debugging-output");
  2814 
  2815   defsubr (&Sexternal_debugging_output);
  2816 }
  2817 
  2818 void
  2819 syms_of_print (void)
  2820 {
  2821   DEFSYM (Qtemp_buffer_setup_hook, "temp-buffer-setup-hook");
  2822 
  2823   DEFVAR_LISP ("standard-output", Vstandard_output,
  2824                doc: /* Output stream `print' uses by default for outputting a character.
  2825 This may be any function of one argument.
  2826 It may also be a buffer (output is inserted before point)
  2827 or a marker (output is inserted and the marker is advanced)
  2828 or the symbol t (output appears in the echo area).  */);
  2829   Vstandard_output = Qt;
  2830   DEFSYM (Qstandard_output, "standard-output");
  2831 
  2832   DEFVAR_LISP ("float-output-format", Vfloat_output_format,
  2833                doc: /* The format descriptor string used to print floats.
  2834 This is a %-spec like those accepted by `printf' in C,
  2835 but with some restrictions.  It must start with the two characters `%.'.
  2836 After that comes an integer precision specification,
  2837 and then a letter which controls the format.
  2838 The letters allowed are `e', `f' and `g'.
  2839 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
  2840 Use `f' for decimal point notation \"DIGITS.DIGITS\".
  2841 Use `g' to choose the shorter of those two formats for the number at hand.
  2842 The precision in any of these cases is the number of digits following
  2843 the decimal point.  With `f', a precision of 0 means to omit the
  2844 decimal point.  0 is not allowed with `e' or `g'.
  2845 
  2846 A value of nil means to use the shortest notation
  2847 that represents the number without losing information.  */);
  2848   Vfloat_output_format = Qnil;
  2849 
  2850   DEFVAR_BOOL ("print-integers-as-characters", print_integers_as_characters,
  2851                doc: /* Non-nil means integers are printed using characters syntax.
  2852 Only independent graphic characters, and control characters with named
  2853 escape sequences such as newline, are printed this way.  Other
  2854 integers, including those corresponding to raw bytes, are printed
  2855 as numbers the usual way.  */);
  2856   print_integers_as_characters = false;
  2857 
  2858   DEFVAR_LISP ("print-length", Vprint_length,
  2859                doc: /* Maximum length of list to print before abbreviating.
  2860 A value of nil means no limit.  See also `eval-expression-print-length'.  */);
  2861   Vprint_length = Qnil;
  2862 
  2863   DEFVAR_LISP ("print-level", Vprint_level,
  2864                doc: /* Maximum depth of list nesting to print before abbreviating.
  2865 A value of nil means no limit.  See also `eval-expression-print-level'.  */);
  2866   Vprint_level = Qnil;
  2867 
  2868   DEFVAR_BOOL ("print-escape-newlines", print_escape_newlines,
  2869                doc: /* Non-nil means print newlines in strings as `\\n'.
  2870 Also print formfeeds as `\\f'.  */);
  2871   print_escape_newlines = 0;
  2872 
  2873   DEFVAR_BOOL ("print-escape-control-characters", print_escape_control_characters,
  2874                doc: /* Non-nil means print control characters in strings as `\\OOO'.
  2875 \(OOO is the octal representation of the character code.)*/);
  2876   print_escape_control_characters = 0;
  2877 
  2878   DEFVAR_BOOL ("print-escape-nonascii", print_escape_nonascii,
  2879                doc: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
  2880 \(OOO is the octal representation of the character code.)
  2881 Only single-byte characters are affected, and only in `prin1'.
  2882 When the output goes in a multibyte buffer, this feature is
  2883 enabled regardless of the value of the variable.  */);
  2884   print_escape_nonascii = 0;
  2885 
  2886   DEFVAR_BOOL ("print-escape-multibyte", print_escape_multibyte,
  2887                doc: /* Non-nil means print multibyte characters in strings as \\xXXXX.
  2888 \(XXXX is the hex representation of the character code.)
  2889 This affects only `prin1'.  */);
  2890   print_escape_multibyte = 0;
  2891 
  2892   DEFVAR_BOOL ("print-quoted", print_quoted,
  2893                doc: /* Non-nil means print quoted forms with reader syntax.
  2894 I.e., (quote foo) prints as \\='foo, (function foo) as #\\='foo.  */);
  2895   print_quoted = true;
  2896 
  2897   DEFVAR_LISP ("print-gensym", Vprint_gensym,
  2898                doc: /* Non-nil means print uninterned symbols so they will read as uninterned.
  2899 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
  2900 When the uninterned symbol appears multiple times within the printed
  2901 expression, and `print-circle' is non-nil, in addition use the #N#
  2902 and #N= constructs as needed, so that multiple references to the same
  2903 symbol are shared once again when the text is read back.  */);
  2904   Vprint_gensym = Qnil;
  2905 
  2906   DEFVAR_LISP ("print-circle", Vprint_circle,
  2907                doc: /* Non-nil means print recursive structures using #N= and #N# syntax.
  2908 If nil, printing proceeds recursively and may lead to
  2909 `max-lisp-eval-depth' being exceeded or an error may occur:
  2910 \"Apparently circular structure being printed.\"  Also see
  2911 `print-length' and `print-level'.
  2912 If non-nil, shared substructures anywhere in the structure are printed
  2913 with `#N=' before the first occurrence (in the order of the print
  2914 representation) and `#N#' in place of each subsequent occurrence,
  2915 where N is a positive decimal integer.  */);
  2916   Vprint_circle = Qnil;
  2917 
  2918   DEFVAR_LISP ("print-continuous-numbering", Vprint_continuous_numbering,
  2919                doc: /* Non-nil means number continuously across print calls.
  2920 This affects the numbers printed for #N= labels and #M# references.
  2921 See also `print-circle', `print-gensym', and `print-number-table'.
  2922 This variable should not be set with `setq'; bind it with a `let' instead.  */);
  2923   Vprint_continuous_numbering = Qnil;
  2924 
  2925   DEFVAR_LISP ("print-number-table", Vprint_number_table,
  2926                doc: /* A vector used internally to produce `#N=' labels and `#N#' references.
  2927 The Lisp printer uses this vector to detect Lisp objects referenced more
  2928 than once.
  2929 
  2930 When you bind `print-continuous-numbering' to t, you should probably
  2931 also bind `print-number-table' to nil.  This ensures that the value of
  2932 `print-number-table' can be garbage-collected once the printing is
  2933 done.  If all elements of `print-number-table' are nil, it means that
  2934 the printing done so far has not found any shared structure or objects
  2935 that need to be recorded in the table.  */);
  2936   Vprint_number_table = Qnil;
  2937 
  2938   DEFVAR_LISP ("print-charset-text-property", Vprint_charset_text_property,
  2939                doc: /* A flag to control printing of `charset' text property on printing a string.
  2940 The value should be nil, t, or `default'.
  2941 
  2942 If the value is nil, don't print the text property `charset'.
  2943 
  2944 If the value is t, always print the text property `charset'.
  2945 
  2946 If the value is `default', print the text property `charset' only when
  2947 the value is different from what is guessed in the current charset
  2948 priorities.  Values other than nil or t are also treated as
  2949 `default'.  */);
  2950   Vprint_charset_text_property = Qdefault;
  2951 
  2952   DEFVAR_BOOL ("print-symbols-bare", print_symbols_bare,
  2953                doc: /* A flag to control printing of symbols with position.
  2954 If the value is nil, print these objects complete with position.
  2955 Otherwise print just the bare symbol.  */);
  2956   print_symbols_bare = false;
  2957   DEFSYM (Qprint_symbols_bare, "print-symbols-bare");
  2958 
  2959   /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
  2960   staticpro (&Vprin1_to_string_buffer);
  2961 
  2962   defsubr (&Sprin1);
  2963   defsubr (&Sprin1_to_string);
  2964   defsubr (&Serror_message_string);
  2965   defsubr (&Sprinc);
  2966   defsubr (&Sprint);
  2967   defsubr (&Sterpri);
  2968   defsubr (&Swrite_char);
  2969   defsubr (&Sredirect_debugging_output);
  2970   defsubr (&Sprint_preprocess);
  2971 
  2972   DEFSYM (Qprint_escape_multibyte, "print-escape-multibyte");
  2973   DEFSYM (Qprint_escape_nonascii, "print-escape-nonascii");
  2974 
  2975   print_prune_charset_plist = Qnil;
  2976   staticpro (&print_prune_charset_plist);
  2977 
  2978   DEFVAR_LISP ("print-unreadable-function", Vprint_unreadable_function,
  2979                doc: /* If non-nil, a function to call when printing unreadable objects.
  2980 By default, Emacs printing functions (like `prin1') print unreadable
  2981 objects as \"#<...>\", where \"...\" describes the object (for
  2982 instance, \"#<marker in no buffer>\").
  2983 
  2984 If non-nil, it should be a function that will be called with two
  2985 arguments: the object to be printed, and the NOESCAPE flag (see
  2986 `prin1-to-string').  If this function returns nil, the object will be
  2987 printed as usual.  If it returns a string, that string will then be
  2988 printed.  If the function returns anything else, the object will not
  2989 be printed.  */);
  2990   Vprint_unreadable_function = Qnil;
  2991   DEFSYM (Qprint_unreadable_function, "print-unreadable-function");
  2992 
  2993   DEFVAR_LISP ("print--unreadable-callback-buffer",
  2994                Vprint__unreadable_callback_buffer,
  2995                doc: /* Dynamically bound to indicate current buffer.  */);
  2996   Vprint__unreadable_callback_buffer = Qnil;
  2997   DEFSYM (Qprint__unreadable_callback_buffer,
  2998           "print--unreadable-callback-buffer");
  2999   /* Don't export this variable to Elisp.  */
  3000   Funintern (Qprint__unreadable_callback_buffer, Qnil);
  3001 
  3002   defsubr (&Sflush_standard_output);
  3003 
  3004   /* Initialized in print_create_variable_mapping.  */
  3005   staticpro (&Vprint_variable_mapping);
  3006 }