1 /* Lisp object printing and output streams.
   2    Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997,
   3                  1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4                  2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
   5 
   6 This file is part of GNU Emacs.
   7 
   8 GNU Emacs is free software: you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation, either version 3 of the License, or
  11 (at your option) any later version.
  12 
  13 GNU Emacs is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17 
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
  20 
  21 
  22 #include <config.h>
  23 #include <stdio.h>
  24 #include <setjmp.h>
  25 #include "lisp.h"
  26 #include "buffer.h"
  27 #include "character.h"
  28 #include "charset.h"
  29 #include "keyboard.h"
  30 #include "frame.h"
  31 #include "window.h"
  32 #include "process.h"
  33 #include "dispextern.h"
  34 #include "termchar.h"
  35 #include "intervals.h"
  36 #include "blockinput.h"
  37 #include "termhooks.h"          /* For struct terminal.  */
  38 #include "font.h"
  39 
  40 Lisp_Object Vstandard_output, Qstandard_output;
  41 
  42 Lisp_Object Qtemp_buffer_setup_hook;
  43 
  44 /* These are used to print like we read.  */
  45 extern Lisp_Object Qbackquote, Qcomma, Qcomma_at, Qcomma_dot, Qfunction;
  46 
  47 Lisp_Object Vfloat_output_format, Qfloat_output_format;
  48 
  49 #include <math.h>
  50 
  51 #if STDC_HEADERS
  52 #include <float.h>
  53 #endif
  54 
  55 /* Default to values appropriate for IEEE floating point.  */
  56 #ifndef FLT_RADIX
  57 #define FLT_RADIX 2
  58 #endif
  59 #ifndef DBL_MANT_DIG
  60 #define DBL_MANT_DIG 53
  61 #endif
  62 #ifndef DBL_DIG
  63 #define DBL_DIG 15
  64 #endif
  65 #ifndef DBL_MIN
  66 #define DBL_MIN 2.2250738585072014e-308
  67 #endif
  68 
  69 #ifdef DBL_MIN_REPLACEMENT
  70 #undef DBL_MIN
  71 #define DBL_MIN DBL_MIN_REPLACEMENT
  72 #endif
  73 
  74 /* Define DOUBLE_DIGITS_BOUND, an upper bound on the number of decimal digits
  75    needed to express a float without losing information.
  76    The general-case formula is valid for the usual case, IEEE floating point,
  77    but many compilers can't optimize the formula to an integer constant,
  78    so make a special case for it.  */
  79 #if FLT_RADIX == 2 && DBL_MANT_DIG == 53
  80 #define DOUBLE_DIGITS_BOUND 17 /* IEEE floating point */
  81 #else
  82 #define DOUBLE_DIGITS_BOUND ((int) ceil (log10 (pow (FLT_RADIX, DBL_MANT_DIG))))
  83 #endif
  84 
  85 /* Avoid actual stack overflow in print.  */
  86 int print_depth;
  87 
  88 /* Level of nesting inside outputting backquote in new style.  */
  89 int new_backquote_output;
  90 
  91 /* Detect most circularities to print finite output.  */
  92 #define PRINT_CIRCLE 200
  93 Lisp_Object being_printed[PRINT_CIRCLE];
  94 
  95 /* When printing into a buffer, first we put the text in this
  96    block, then insert it all at once.  */
  97 char *print_buffer;
  98 
  99 /* Size allocated in print_buffer.  */
 100 int print_buffer_size;
 101 /* Chars stored in print_buffer.  */
 102 int print_buffer_pos;
 103 /* Bytes stored in print_buffer.  */
 104 int print_buffer_pos_byte;
 105 
 106 /* Maximum length of list to print in full; noninteger means
 107    effectively infinity */
 108 
 109 Lisp_Object Vprint_length;
 110 
 111 /* Maximum depth of list to print in full; noninteger means
 112    effectively infinity.  */
 113 
 114 Lisp_Object Vprint_level;
 115 
 116 /* Nonzero means print newlines in strings as \n.  */
 117 
 118 int print_escape_newlines;
 119 
 120 /* Nonzero means to print single-byte non-ascii characters in strings as
 121    octal escapes.  */
 122 
 123 int print_escape_nonascii;
 124 
 125 /* Nonzero means to print multibyte characters in strings as hex escapes.  */
 126 
 127 int print_escape_multibyte;
 128 
 129 Lisp_Object Qprint_escape_newlines;
 130 Lisp_Object Qprint_escape_multibyte, Qprint_escape_nonascii;
 131 
 132 /* Nonzero means print (quote foo) forms as 'foo, etc.  */
 133 
 134 int print_quoted;
 135 
 136 /* Non-nil means print #: before uninterned symbols.  */
 137 
 138 Lisp_Object Vprint_gensym;
 139 
 140 /* Non-nil means print recursive structures using #n= and #n# syntax.  */
 141 
 142 Lisp_Object Vprint_circle;
 143 
 144 /* Non-nil means keep continuous number for #n= and #n# syntax
 145    between several print functions.  */
 146 
 147 Lisp_Object Vprint_continuous_numbering;
 148 
 149 /* Vprint_number_table is a vector like [OBJ1 STAT1 OBJ2 STAT2 ...],
 150    where OBJn are objects going to be printed, and STATn are their status,
 151    which may be different meanings during process.  See the comments of
 152    the functions print and print_preprocess for details.
 153    print_number_index keeps the last position the next object should be added,
 154    twice of which is the actual vector position in Vprint_number_table.  */
 155 int print_number_index;
 156 Lisp_Object Vprint_number_table;
 157 
 158 /* PRINT_NUMBER_OBJECT returns the I'th object in Vprint_number_table TABLE.
 159    PRINT_NUMBER_STATUS returns the status of the I'th object in TABLE.
 160    See the comment of the variable Vprint_number_table.  */
 161 #define PRINT_NUMBER_OBJECT(table,i) XVECTOR ((table))->contents[(i) * 2]
 162 #define PRINT_NUMBER_STATUS(table,i) XVECTOR ((table))->contents[(i) * 2 + 1]
 163 
 164 /* Nonzero means print newline to stdout before next minibuffer message.
 165    Defined in xdisp.c */
 166 
 167 extern int noninteractive_need_newline;
 168 
 169 extern int minibuffer_auto_raise;
 170 
 171 void print_interval ();
 172 
 173 /* GDB resets this to zero on W32 to disable OutputDebugString calls.  */
 174 int print_output_debug_flag = 1;
 175 
 176 
 177 /* Low level output routines for characters and strings */
 178 
 179 /* Lisp functions to do output using a stream
 180    must have the stream in a variable called printcharfun
 181    and must start with PRINTPREPARE, end with PRINTFINISH,
 182    and use PRINTDECLARE to declare common variables.
 183    Use PRINTCHAR to output one character,
 184    or call strout to output a block of characters. */
 185 
 186 #define PRINTDECLARE                                                    \
 187    struct buffer *old = current_buffer;                                 \
 188    int old_point = -1, start_point = -1;                                \
 189    int old_point_byte = -1, start_point_byte = -1;                      \
 190    int specpdl_count = SPECPDL_INDEX ();                                \
 191    int free_print_buffer = 0;                                           \
 192    int multibyte = !NILP (current_buffer->enable_multibyte_characters); \
 193    Lisp_Object original
 194 
 195 #define PRINTPREPARE                                                    \
 196    original = printcharfun;                                             \
 197    if (NILP (printcharfun)) printcharfun = Qt;                          \
 198    if (BUFFERP (printcharfun))                                          \
 199      {                                                                  \
 200        if (XBUFFER (printcharfun) != current_buffer)                    \
 201          Fset_buffer (printcharfun);                                    \
 202        printcharfun = Qnil;                                             \
 203      }                                                                  \
 204    if (MARKERP (printcharfun))                                          \
 205      {                                                                  \
 206        EMACS_INT marker_pos;                                            \
 207        if (! XMARKER (printcharfun)->buffer)                            \
 208          error ("Marker does not point anywhere");                      \
 209        if (XMARKER (printcharfun)->buffer != current_buffer)            \
 210          set_buffer_internal (XMARKER (printcharfun)->buffer);          \
 211        marker_pos = marker_position (printcharfun);                     \
 212        if (marker_pos < BEGV || marker_pos > ZV)                        \
 213          error ("Marker is outside the accessible part of the buffer"); \
 214        old_point = PT;                                                  \
 215        old_point_byte = PT_BYTE;                                        \
 216        SET_PT_BOTH (marker_pos,                                         \
 217                     marker_byte_position (printcharfun));               \
 218        start_point = PT;                                                \
 219        start_point_byte = PT_BYTE;                                      \
 220        printcharfun = Qnil;                                             \
 221      }                                                                  \
 222    if (NILP (printcharfun))                                             \
 223      {                                                                  \
 224        Lisp_Object string;                                              \
 225        if (NILP (current_buffer->enable_multibyte_characters)           \
 226            && ! print_escape_multibyte)                                 \
 227          specbind (Qprint_escape_multibyte, Qt);                        \
 228        if (! NILP (current_buffer->enable_multibyte_characters)         \
 229            && ! print_escape_nonascii)                                  \
 230          specbind (Qprint_escape_nonascii, Qt);                         \
 231        if (print_buffer != 0)                                           \
 232          {                                                              \
 233            string = make_string_from_bytes (print_buffer,               \
 234                                             print_buffer_pos,           \
 235                                             print_buffer_pos_byte);     \
 236            record_unwind_protect (print_unwind, string);                \
 237          }                                                              \
 238        else                                                             \
 239          {                                                              \
 240            print_buffer_size = 1000;                                    \
 241            print_buffer = (char *) xmalloc (print_buffer_size);         \
 242            free_print_buffer = 1;                                       \
 243          }                                                              \
 244        print_buffer_pos = 0;                                            \
 245        print_buffer_pos_byte = 0;                                       \
 246      }                                                                  \
 247    if (EQ (printcharfun, Qt) && ! noninteractive)                       \
 248      setup_echo_area_for_printing (multibyte);
 249 
 250 #define PRINTFINISH                                                     \
 251    if (NILP (printcharfun))                                             \
 252      {                                                                  \
 253        if (print_buffer_pos != print_buffer_pos_byte                    \
 254            && NILP (current_buffer->enable_multibyte_characters))       \
 255          {                                                              \
 256            unsigned char *temp                                          \
 257              = (unsigned char *) alloca (print_buffer_pos + 1);         \
 258            copy_text (print_buffer, temp, print_buffer_pos_byte,        \
 259                       1, 0);                                            \
 260            insert_1_both (temp, print_buffer_pos,                       \
 261                           print_buffer_pos, 0, 1, 0);                   \
 262          }                                                              \
 263        else                                                             \
 264          insert_1_both (print_buffer, print_buffer_pos,                 \
 265                         print_buffer_pos_byte, 0, 1, 0);                \
 266        signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
 267      }                                                                  \
 268    if (free_print_buffer)                                               \
 269      {                                                                  \
 270        xfree (print_buffer);                                            \
 271        print_buffer = 0;                                                \
 272      }                                                                  \
 273    unbind_to (specpdl_count, Qnil);                                     \
 274    if (MARKERP (original))                                              \
 275      set_marker_both (original, Qnil, PT, PT_BYTE);                     \
 276    if (old_point >= 0)                                                  \
 277      SET_PT_BOTH (old_point + (old_point >= start_point                 \
 278                                ? PT - start_point : 0),                 \
 279                   old_point_byte + (old_point_byte >= start_point_byte  \
 280                                     ? PT_BYTE - start_point_byte : 0)); \
 281    if (old != current_buffer)                                           \
 282      set_buffer_internal (old);
 283 
 284 #define PRINTCHAR(ch) printchar (ch, printcharfun)
 285 
 286 /* This is used to restore the saved contents of print_buffer
 287    when there is a recursive call to print.  */
 288 
 289 static Lisp_Object
 290 print_unwind (saved_text)
 291      Lisp_Object saved_text;
 292 {
 293   bcopy (SDATA (saved_text), print_buffer, SCHARS (saved_text));
 294   return Qnil;
 295 }
 296 
 297 
 298 /* Print character CH using method FUN.  FUN nil means print to
 299    print_buffer.  FUN t means print to echo area or stdout if
 300    non-interactive.  If FUN is neither nil nor t, call FUN with CH as
 301    argument.  */
 302 
 303 static void
 304 printchar (ch, fun)
 305      unsigned int ch;
 306      Lisp_Object fun;
 307 {
 308   if (!NILP (fun) && !EQ (fun, Qt))
 309     call1 (fun, make_number (ch));
 310   else
 311     {
 312       unsigned char str[MAX_MULTIBYTE_LENGTH];
 313       int len = CHAR_STRING (ch, str);
 314 
 315       QUIT;
 316 
 317       if (NILP (fun))
 318         {
 319           if (print_buffer_pos_byte + len >= print_buffer_size)
 320             print_buffer = (char *) xrealloc (print_buffer,
 321                                               print_buffer_size *= 2);
 322           bcopy (str, print_buffer + print_buffer_pos_byte, len);
 323           print_buffer_pos += 1;
 324           print_buffer_pos_byte += len;
 325         }
 326       else if (noninteractive)
 327         {
 328           fwrite (str, 1, len, stdout);
 329           noninteractive_need_newline = 1;
 330         }
 331       else
 332         {
 333           int multibyte_p
 334             = !NILP (current_buffer->enable_multibyte_characters);
 335 
 336           setup_echo_area_for_printing (multibyte_p);
 337           insert_char (ch);
 338           message_dolog (str, len, 0, multibyte_p);
 339         }
 340     }
 341 }
 342 
 343 
 344 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
 345    method PRINTCHARFUN.  If SIZE < 0, use the string length of PTR for
 346    both SIZE and SIZE_BYTE.  PRINTCHARFUN nil means output to
 347    print_buffer.  PRINTCHARFUN t means output to the echo area or to
 348    stdout if non-interactive.  If neither nil nor t, call Lisp
 349    function PRINTCHARFUN for each character printed.  MULTIBYTE
 350    non-zero means PTR contains multibyte characters.
 351 
 352    In the case where PRINTCHARFUN is nil, it is safe for PTR to point
 353    to data in a Lisp string.  Otherwise that is not safe.  */
 354 
 355 static void
 356 strout (ptr, size, size_byte, printcharfun, multibyte)
 357      char *ptr;
 358      int size, size_byte;
 359      Lisp_Object printcharfun;
 360      int multibyte;
 361 {
 362   if (size < 0)
 363     size_byte = size = strlen (ptr);
 364 
 365   if (NILP (printcharfun))
 366     {
 367       if (print_buffer_pos_byte + size_byte > print_buffer_size)
 368         {
 369           print_buffer_size = print_buffer_size * 2 + size_byte;
 370           print_buffer = (char *) xrealloc (print_buffer,
 371                                             print_buffer_size);
 372         }
 373       bcopy (ptr, print_buffer + print_buffer_pos_byte, size_byte);
 374       print_buffer_pos += size;
 375       print_buffer_pos_byte += size_byte;
 376     }
 377   else if (noninteractive && EQ (printcharfun, Qt))
 378     {
 379       fwrite (ptr, 1, size_byte, stdout);
 380       noninteractive_need_newline = 1;
 381     }
 382   else if (EQ (printcharfun, Qt))
 383     {
 384       /* Output to echo area.  We're trying to avoid a little overhead
 385          here, that's the reason we don't call printchar to do the
 386          job.  */
 387       int i;
 388       int multibyte_p
 389         = !NILP (current_buffer->enable_multibyte_characters);
 390 
 391       setup_echo_area_for_printing (multibyte_p);
 392       message_dolog (ptr, size_byte, 0, multibyte_p);
 393 
 394       if (size == size_byte)
 395         {
 396           for (i = 0; i < size; ++i)
 397             insert_char ((unsigned char) *ptr++);
 398         }
 399       else
 400         {
 401           int len;
 402           for (i = 0; i < size_byte; i += len)
 403             {
 404               int ch = STRING_CHAR_AND_LENGTH (ptr + i, len);
 405               insert_char (ch);
 406             }
 407         }
 408     }
 409   else
 410     {
 411       /* PRINTCHARFUN is a Lisp function.  */
 412       int i = 0;
 413 
 414       if (size == size_byte)
 415         {
 416           while (i < size_byte)
 417             {
 418               int ch = ptr[i++];
 419               PRINTCHAR (ch);
 420             }
 421         }
 422       else
 423         {
 424           while (i < size_byte)
 425             {
 426               /* Here, we must convert each multi-byte form to the
 427                  corresponding character code before handing it to
 428                  PRINTCHAR.  */
 429               int len;
 430               int ch = STRING_CHAR_AND_LENGTH (ptr + i, len);
 431               PRINTCHAR (ch);
 432               i += len;
 433             }
 434         }
 435     }
 436 }
 437 
 438 /* Print the contents of a string STRING using PRINTCHARFUN.
 439    It isn't safe to use strout in many cases,
 440    because printing one char can relocate.  */
 441 
 442 static void
 443 print_string (string, printcharfun)
 444      Lisp_Object string;
 445      Lisp_Object printcharfun;
 446 {
 447   if (EQ (printcharfun, Qt) || NILP (printcharfun))
 448     {
 449       int chars;
 450 
 451       if (print_escape_nonascii)
 452         string = string_escape_byte8 (string);
 453 
 454       if (STRING_MULTIBYTE (string))
 455         chars = SCHARS (string);
 456       else if (! print_escape_nonascii
 457                && (EQ (printcharfun, Qt)
 458                    ? ! NILP (buffer_defaults.enable_multibyte_characters)
 459                    : ! NILP (current_buffer->enable_multibyte_characters)))
 460         {
 461           /* If unibyte string STRING contains 8-bit codes, we must
 462              convert STRING to a multibyte string containing the same
 463              character codes.  */
 464           Lisp_Object newstr;
 465           int bytes;
 466 
 467           chars = SBYTES (string);
 468           bytes = parse_str_to_multibyte (SDATA (string), chars);
 469           if (chars < bytes)
 470             {
 471               newstr = make_uninit_multibyte_string (chars, bytes);
 472               bcopy (SDATA (string), SDATA (newstr), chars);
 473               str_to_multibyte (SDATA (newstr), bytes, chars);
 474               string = newstr;
 475             }
 476         }
 477       else
 478         chars = SBYTES (string);
 479 
 480       if (EQ (printcharfun, Qt))
 481         {
 482           /* Output to echo area.  */
 483           int nbytes = SBYTES (string);
 484           char *buffer;
 485 
 486           /* Copy the string contents so that relocation of STRING by
 487              GC does not cause trouble.  */
 488           USE_SAFE_ALLOCA;
 489 
 490           SAFE_ALLOCA (buffer, char *, nbytes);
 491           bcopy (SDATA (string), buffer, nbytes);
 492 
 493           strout (buffer, chars, SBYTES (string),
 494                   printcharfun, STRING_MULTIBYTE (string));
 495 
 496           SAFE_FREE ();
 497         }
 498       else
 499         /* No need to copy, since output to print_buffer can't GC.  */
 500         strout (SDATA (string),
 501                 chars, SBYTES (string),
 502                 printcharfun, STRING_MULTIBYTE (string));
 503     }
 504   else
 505     {
 506       /* Otherwise, string may be relocated by printing one char.
 507          So re-fetch the string address for each character.  */
 508       int i;
 509       int size = SCHARS (string);
 510       int size_byte = SBYTES (string);
 511       struct gcpro gcpro1;
 512       GCPRO1 (string);
 513       if (size == size_byte)
 514         for (i = 0; i < size; i++)
 515           PRINTCHAR (SREF (string, i));
 516       else
 517         for (i = 0; i < size_byte; )
 518           {
 519             /* Here, we must convert each multi-byte form to the
 520                corresponding character code before handing it to PRINTCHAR.  */
 521             int len;
 522             int ch = STRING_CHAR_AND_LENGTH (SDATA (string) + i, len);
 523             PRINTCHAR (ch);
 524             i += len;
 525           }
 526       UNGCPRO;
 527     }
 528 }
 529 
 530 DEFUN ("write-char", Fwrite_char, Swrite_char, 1, 2, 0,
 531        doc: /* Output character CHARACTER to stream PRINTCHARFUN.
 532 PRINTCHARFUN defaults to the value of `standard-output' (which see).  */)
 533      (character, printcharfun)
 534      Lisp_Object character, printcharfun;
 535 {
 536   PRINTDECLARE;
 537 
 538   if (NILP (printcharfun))
 539     printcharfun = Vstandard_output;
 540   CHECK_NUMBER (character);
 541   PRINTPREPARE;
 542   PRINTCHAR (XINT (character));
 543   PRINTFINISH;
 544   return character;
 545 }
 546 
 547 /* Used from outside of print.c to print a block of SIZE
 548    single-byte chars at DATA on the default output stream.
 549    Do not use this on the contents of a Lisp string.  */
 550 
 551 void
 552 write_string (data, size)
 553      char *data;
 554      int size;
 555 {
 556   PRINTDECLARE;
 557   Lisp_Object printcharfun;
 558 
 559   printcharfun = Vstandard_output;
 560 
 561   PRINTPREPARE;
 562   strout (data, size, size, printcharfun, 0);
 563   PRINTFINISH;
 564 }
 565 
 566 /* Used from outside of print.c to print a block of SIZE
 567    single-byte chars at DATA on a specified stream PRINTCHARFUN.
 568    Do not use this on the contents of a Lisp string.  */
 569 
 570 void
 571 write_string_1 (data, size, printcharfun)
 572      char *data;
 573      int size;
 574      Lisp_Object printcharfun;
 575 {
 576   PRINTDECLARE;
 577 
 578   PRINTPREPARE;
 579   strout (data, size, size, printcharfun, 0);
 580   PRINTFINISH;
 581 }
 582 
 583 
 584 void
 585 temp_output_buffer_setup (bufname)
 586     const char *bufname;
 587 {
 588   int count = SPECPDL_INDEX ();
 589   register struct buffer *old = current_buffer;
 590   register Lisp_Object buf;
 591 
 592   record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ());
 593 
 594   Fset_buffer (Fget_buffer_create (build_string (bufname)));
 595 
 596   Fkill_all_local_variables ();
 597   delete_all_overlays (current_buffer);
 598   current_buffer->directory = old->directory;
 599   current_buffer->read_only = Qnil;
 600   current_buffer->filename = Qnil;
 601   current_buffer->undo_list = Qt;
 602   eassert (current_buffer->overlays_before == NULL);
 603   eassert (current_buffer->overlays_after == NULL);
 604   current_buffer->enable_multibyte_characters
 605     = buffer_defaults.enable_multibyte_characters;
 606   specbind (Qinhibit_read_only, Qt);
 607   specbind (Qinhibit_modification_hooks, Qt);
 608   Ferase_buffer ();
 609   XSETBUFFER (buf, current_buffer);
 610 
 611   Frun_hooks (1, &Qtemp_buffer_setup_hook);
 612 
 613   unbind_to (count, Qnil);
 614 
 615   specbind (Qstandard_output, buf);
 616 }
 617 
 618 Lisp_Object
 619 internal_with_output_to_temp_buffer (bufname, function, args)
 620      const char *bufname;
 621      Lisp_Object (*function) P_ ((Lisp_Object));
 622      Lisp_Object args;
 623 {
 624   int count = SPECPDL_INDEX ();
 625   Lisp_Object buf, val;
 626   struct gcpro gcpro1;
 627 
 628   GCPRO1 (args);
 629   record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
 630   temp_output_buffer_setup (bufname);
 631   buf = Vstandard_output;
 632   UNGCPRO;
 633 
 634   val = (*function) (args);
 635 
 636   GCPRO1 (val);
 637   temp_output_buffer_show (buf);
 638   UNGCPRO;
 639 
 640   return unbind_to (count, val);
 641 }
 642 
 643 DEFUN ("with-output-to-temp-buffer",
 644        Fwith_output_to_temp_buffer, Swith_output_to_temp_buffer,
 645        1, UNEVALLED, 0,
 646        doc: /* Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
 647 
 648 This construct makes buffer BUFNAME empty before running BODY.
 649 It does not make the buffer current for BODY.
 650 Instead it binds `standard-output' to that buffer, so that output
 651 generated with `prin1' and similar functions in BODY goes into
 652 the buffer.
 653 
 654 At the end of BODY, this marks buffer BUFNAME unmodifed and displays
 655 it in a window, but does not select it.  The normal way to do this is
 656 by calling `display-buffer', then running `temp-buffer-show-hook'.
 657 However, if `temp-buffer-show-function' is non-nil, it calls that
 658 function instead (and does not run `temp-buffer-show-hook').  The
 659 function gets one argument, the buffer to display.
 660 
 661 The return value of `with-output-to-temp-buffer' is the value of the
 662 last form in BODY.  If BODY does not finish normally, the buffer
 663 BUFNAME is not displayed.
 664 
 665 This runs the hook `temp-buffer-setup-hook' before BODY,
 666 with the buffer BUFNAME temporarily current.  It runs the hook
 667 `temp-buffer-show-hook' after displaying buffer BUFNAME, with that
 668 buffer temporarily current, and the window that was used to display it
 669 temporarily selected.  But it doesn't run `temp-buffer-show-hook'
 670 if it uses `temp-buffer-show-function'.
 671 
 672 usage: (with-output-to-temp-buffer BUFNAME BODY...)  */)
 673      (args)
 674      Lisp_Object args;
 675 {
 676   struct gcpro gcpro1;
 677   Lisp_Object name;
 678   int count = SPECPDL_INDEX ();
 679   Lisp_Object buf, val;
 680 
 681   GCPRO1(args);
 682   name = Feval (Fcar (args));
 683   CHECK_STRING (name);
 684   temp_output_buffer_setup (SDATA (name));
 685   buf = Vstandard_output;
 686   UNGCPRO;
 687 
 688   val = Fprogn (XCDR (args));
 689 
 690   GCPRO1 (val);
 691   temp_output_buffer_show (buf);
 692   UNGCPRO;
 693 
 694   return unbind_to (count, val);
 695 }
 696 
 697 
 698 static void print ();
 699 static void print_preprocess ();
 700 static void print_preprocess_string ();
 701 static void print_object ();
 702 
 703 DEFUN ("terpri", Fterpri, Sterpri, 0, 1, 0,
 704        doc: /* Output a newline to stream PRINTCHARFUN.
 705 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used.  */)
 706   (printcharfun)
 707      Lisp_Object printcharfun;
 708 {
 709   PRINTDECLARE;
 710 
 711   if (NILP (printcharfun))
 712     printcharfun = Vstandard_output;
 713   PRINTPREPARE;
 714   PRINTCHAR ('\n');
 715   PRINTFINISH;
 716   return Qt;
 717 }
 718 
 719 DEFUN ("prin1", Fprin1, Sprin1, 1, 2, 0,
 720        doc: /* Output the printed representation of OBJECT, any Lisp object.
 721 Quoting characters are printed when needed to make output that `read'
 722 can handle, whenever this is possible.  For complex objects, the behavior
 723 is controlled by `print-level' and `print-length', which see.
 724 
 725 OBJECT is any of the Lisp data types: a number, a string, a symbol,
 726 a list, a buffer, a window, a frame, etc.
 727 
 728 A printed representation of an object is text which describes that object.
 729 
 730 Optional argument PRINTCHARFUN is the output stream, which can be one
 731 of these:
 732 
 733    - a buffer, in which case output is inserted into that buffer at point;
 734    - a marker, in which case output is inserted at marker's position;
 735    - a function, in which case that function is called once for each
 736      character of OBJECT's printed representation;
 737    - a symbol, in which case that symbol's function definition is called; or
 738    - t, in which case the output is displayed in the echo area.
 739 
 740 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
 741 is used instead.  */)
 742      (object, printcharfun)
 743      Lisp_Object object, printcharfun;
 744 {
 745   PRINTDECLARE;
 746 
 747   if (NILP (printcharfun))
 748     printcharfun = Vstandard_output;
 749   PRINTPREPARE;
 750   print (object, printcharfun, 1);
 751   PRINTFINISH;
 752   return object;
 753 }
 754 
 755 /* a buffer which is used to hold output being built by prin1-to-string */
 756 Lisp_Object Vprin1_to_string_buffer;
 757 
 758 DEFUN ("prin1-to-string", Fprin1_to_string, Sprin1_to_string, 1, 2, 0,
 759        doc: /* Return a string containing the printed representation of OBJECT.
 760 OBJECT can be any Lisp object.  This function outputs quoting characters
 761 when necessary to make output that `read' can handle, whenever possible,
 762 unless the optional second argument NOESCAPE is non-nil.  For complex objects,
 763 the behavior is controlled by `print-level' and `print-length', which see.
 764 
 765 OBJECT is any of the Lisp data types: a number, a string, a symbol,
 766 a list, a buffer, a window, a frame, etc.
 767 
 768 A printed representation of an object is text which describes that object.  */)
 769      (object, noescape)
 770      Lisp_Object object, noescape;
 771 {
 772   Lisp_Object printcharfun;
 773   /* struct gcpro gcpro1, gcpro2; */
 774   Lisp_Object save_deactivate_mark;
 775   int count = SPECPDL_INDEX ();
 776   struct buffer *previous;
 777 
 778   specbind (Qinhibit_modification_hooks, Qt);
 779 
 780   {
 781     PRINTDECLARE;
 782 
 783     /* Save and restore this--we are altering a buffer
 784        but we don't want to deactivate the mark just for that.
 785        No need for specbind, since errors deactivate the mark.  */
 786     save_deactivate_mark = Vdeactivate_mark;
 787     /* GCPRO2 (object, save_deactivate_mark); */
 788     abort_on_gc++;
 789 
 790     printcharfun = Vprin1_to_string_buffer;
 791     PRINTPREPARE;
 792     print (object, printcharfun, NILP (noescape));
 793     /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
 794     PRINTFINISH;
 795   }
 796 
 797   previous = current_buffer;
 798   set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
 799   object = Fbuffer_string ();
 800   if (SBYTES (object) == SCHARS (object))
 801     STRING_SET_UNIBYTE (object);
 802 
 803   /* Note that this won't make prepare_to_modify_buffer call
 804      ask-user-about-supersession-threat because this buffer
 805      does not visit a file.  */
 806   Ferase_buffer ();
 807   set_buffer_internal (previous);
 808 
 809   Vdeactivate_mark = save_deactivate_mark;
 810   /* UNGCPRO; */
 811 
 812   abort_on_gc--;
 813   return unbind_to (count, object);
 814 }
 815 
 816 DEFUN ("princ", Fprinc, Sprinc, 1, 2, 0,
 817        doc: /* Output the printed representation of OBJECT, any Lisp object.
 818 No quoting characters are used; no delimiters are printed around
 819 the contents of strings.
 820 
 821 OBJECT is any of the Lisp data types: a number, a string, a symbol,
 822 a list, a buffer, a window, a frame, etc.
 823 
 824 A printed representation of an object is text which describes that object.
 825 
 826 Optional argument PRINTCHARFUN is the output stream, which can be one
 827 of these:
 828 
 829    - a buffer, in which case output is inserted into that buffer at point;
 830    - a marker, in which case output is inserted at marker's position;
 831    - a function, in which case that function is called once for each
 832      character of OBJECT's printed representation;
 833    - a symbol, in which case that symbol's function definition is called; or
 834    - t, in which case the output is displayed in the echo area.
 835 
 836 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
 837 is used instead.  */)
 838      (object, printcharfun)
 839      Lisp_Object object, printcharfun;
 840 {
 841   PRINTDECLARE;
 842 
 843   if (NILP (printcharfun))
 844     printcharfun = Vstandard_output;
 845   PRINTPREPARE;
 846   print (object, printcharfun, 0);
 847   PRINTFINISH;
 848   return object;
 849 }
 850 
 851 DEFUN ("print", Fprint, Sprint, 1, 2, 0,
 852        doc: /* Output the printed representation of OBJECT, with newlines around it.
 853 Quoting characters are printed when needed to make output that `read'
 854 can handle, whenever this is possible.  For complex objects, the behavior
 855 is controlled by `print-level' and `print-length', which see.
 856 
 857 OBJECT is any of the Lisp data types: a number, a string, a symbol,
 858 a list, a buffer, a window, a frame, etc.
 859 
 860 A printed representation of an object is text which describes that object.
 861 
 862 Optional argument PRINTCHARFUN is the output stream, which can be one
 863 of these:
 864 
 865    - a buffer, in which case output is inserted into that buffer at point;
 866    - a marker, in which case output is inserted at marker's position;
 867    - a function, in which case that function is called once for each
 868      character of OBJECT's printed representation;
 869    - a symbol, in which case that symbol's function definition is called; or
 870    - t, in which case the output is displayed in the echo area.
 871 
 872 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
 873 is used instead.  */)
 874      (object, printcharfun)
 875      Lisp_Object object, printcharfun;
 876 {
 877   PRINTDECLARE;
 878   struct gcpro gcpro1;
 879 
 880   if (NILP (printcharfun))
 881     printcharfun = Vstandard_output;
 882   GCPRO1 (object);
 883   PRINTPREPARE;
 884   PRINTCHAR ('\n');
 885   print (object, printcharfun, 1);
 886   PRINTCHAR ('\n');
 887   PRINTFINISH;
 888   UNGCPRO;
 889   return object;
 890 }
 891 
 892 /* The subroutine object for external-debugging-output is kept here
 893    for the convenience of the debugger.  */
 894 Lisp_Object Qexternal_debugging_output;
 895 
 896 DEFUN ("external-debugging-output", Fexternal_debugging_output, Sexternal_debugging_output, 1, 1, 0,
 897        doc: /* Write CHARACTER to stderr.
 898 You can call print while debugging emacs, and pass it this function
 899 to make it write to the debugging output.  */)
 900      (character)
 901      Lisp_Object character;
 902 {
 903   CHECK_NUMBER (character);
 904   putc (XINT (character), stderr);
 905 
 906 #ifdef WINDOWSNT
 907   /* Send the output to a debugger (nothing happens if there isn't one).  */
 908   if (print_output_debug_flag)
 909     {
 910       char buf[2] = {(char) XINT (character), '\0'};
 911       OutputDebugString (buf);
 912     }
 913 #endif
 914 
 915   return character;
 916 }
 917 
 918 /* This function is never called.  Its purpose is to prevent
 919    print_output_debug_flag from being optimized away.  */
 920 
 921 void
 922 debug_output_compilation_hack (x)
 923      int x;
 924 {
 925   print_output_debug_flag = x;
 926 }
 927 
 928 #if defined (GNU_LINUX)
 929 
 930 /* This functionality is not vitally important in general, so we rely on
 931    non-portable ability to use stderr as lvalue.  */
 932 
 933 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
 934 
 935 FILE *initial_stderr_stream = NULL;
 936 
 937 DEFUN ("redirect-debugging-output", Fredirect_debugging_output, Sredirect_debugging_output,
 938        1, 2,
 939        "FDebug output file: \nP",
 940        doc: /* Redirect debugging output (stderr stream) to file FILE.
 941 If FILE is nil, reset target to the initial stderr stream.
 942 Optional arg APPEND non-nil (interactively, with prefix arg) means
 943 append to existing target file.  */)
 944      (file, append)
 945      Lisp_Object file, append;
 946 {
 947   if (initial_stderr_stream != NULL)
 948     {
 949       BLOCK_INPUT;
 950       fclose (stderr);
 951       UNBLOCK_INPUT;
 952     }
 953   stderr = initial_stderr_stream;
 954   initial_stderr_stream = NULL;
 955 
 956   if (STRINGP (file))
 957     {
 958       file = Fexpand_file_name (file, Qnil);
 959       initial_stderr_stream = stderr;
 960       stderr = fopen (SDATA (file), NILP (append) ? "w" : "a");
 961       if (stderr == NULL)
 962         {
 963           stderr = initial_stderr_stream;
 964           initial_stderr_stream = NULL;
 965           report_file_error ("Cannot open debugging output stream",
 966                              Fcons (file, Qnil));
 967         }
 968     }
 969   return Qnil;
 970 }
 971 #endif /* GNU_LINUX */
 972 
 973 
 974 /* This is the interface for debugging printing.  */
 975 
 976 void
 977 debug_print (arg)
 978      Lisp_Object arg;
 979 {
 980   Fprin1 (arg, Qexternal_debugging_output);
 981   fprintf (stderr, "\r\n");
 982 }
 983 
 984 void
 985 safe_debug_print (arg)
 986      Lisp_Object arg;
 987 {
 988   int valid = valid_lisp_object_p (arg);
 989 
 990   if (valid > 0)
 991     debug_print (arg);
 992   else
 993     fprintf (stderr, "#<%s_LISP_OBJECT 0x%08lx>\r\n",
 994              !valid ? "INVALID" : "SOME",
 995              (unsigned long) XHASH (arg)
 996              );
 997 }
 998 
 999 
1000 DEFUN ("error-message-string", Ferror_message_string, Serror_message_string,
1001        1, 1, 0,
1002        doc: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
1003 See Info anchor `(elisp)Definition of signal' for some details on how this
1004 error message is constructed.  */)
1005      (obj)
1006      Lisp_Object obj;
1007 {
1008   struct buffer *old = current_buffer;
1009   Lisp_Object value;
1010   struct gcpro gcpro1;
1011 
1012   /* If OBJ is (error STRING), just return STRING.
1013      That is not only faster, it also avoids the need to allocate
1014      space here when the error is due to memory full.  */
1015   if (CONSP (obj) && EQ (XCAR (obj), Qerror)
1016       && CONSP (XCDR (obj))
1017       && STRINGP (XCAR (XCDR (obj)))
1018       && NILP (XCDR (XCDR (obj))))
1019     return XCAR (XCDR (obj));
1020 
1021   print_error_message (obj, Vprin1_to_string_buffer, 0, Qnil);
1022 
1023   set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
1024   value = Fbuffer_string ();
1025 
1026   GCPRO1 (value);
1027   Ferase_buffer ();
1028   set_buffer_internal (old);
1029   UNGCPRO;
1030 
1031   return value;
1032 }
1033 
1034 /* Print an error message for the error DATA onto Lisp output stream
1035    STREAM (suitable for the print functions).
1036    CONTEXT is a C string describing the context of the error.
1037    CALLER is the Lisp function inside which the error was signaled.  */
1038 
1039 void
1040 print_error_message (data, stream, context, caller)
1041      Lisp_Object data, stream;
1042      char *context;
1043      Lisp_Object caller;
1044 {
1045   Lisp_Object errname, errmsg, file_error, tail;
1046   struct gcpro gcpro1;
1047   int i;
1048 
1049   if (context != 0)
1050     write_string_1 (context, -1, stream);
1051 
1052   /* If we know from where the error was signaled, show it in
1053    *Messages*.  */
1054   if (!NILP (caller) && SYMBOLP (caller))
1055     {
1056       Lisp_Object cname = SYMBOL_NAME (caller);
1057       char *name = alloca (SBYTES (cname));
1058       bcopy (SDATA (cname), name, SBYTES (cname));
1059       message_dolog (name, SBYTES (cname), 0, 0);
1060       message_dolog (": ", 2, 0, 0);
1061     }
1062 
1063   errname = Fcar (data);
1064 
1065   if (EQ (errname, Qerror))
1066     {
1067       data = Fcdr (data);
1068       if (!CONSP (data))
1069         data = Qnil;
1070       errmsg = Fcar (data);
1071       file_error = Qnil;
1072     }
1073   else
1074     {
1075       Lisp_Object error_conditions;
1076       errmsg = Fget (errname, Qerror_message);
1077       error_conditions = Fget (errname, Qerror_conditions);
1078       file_error = Fmemq (Qfile_error, error_conditions);
1079     }
1080 
1081   /* Print an error message including the data items.  */
1082 
1083   tail = Fcdr_safe (data);
1084   GCPRO1 (tail);
1085 
1086   /* For file-error, make error message by concatenating
1087      all the data items.  They are all strings.  */
1088   if (!NILP (file_error) && CONSP (tail))
1089     errmsg = XCAR (tail), tail = XCDR (tail);
1090 
1091   if (STRINGP (errmsg))
1092     Fprinc (errmsg, stream);
1093   else
1094     write_string_1 ("peculiar error", -1, stream);
1095 
1096   for (i = 0; CONSP (tail); tail = XCDR (tail), i++)
1097     {
1098       Lisp_Object obj;
1099 
1100       write_string_1 (i ? ", " : ": ", 2, stream);
1101       obj = XCAR (tail);
1102       if (!NILP (file_error) || EQ (errname, Qend_of_file))
1103         Fprinc (obj, stream);
1104       else
1105         Fprin1 (obj, stream);
1106     }
1107 
1108   UNGCPRO;
1109 }
1110 
1111 
1112 
1113 /*
1114  * The buffer should be at least as large as the max string size of the
1115  * largest float, printed in the biggest notation.  This is undoubtedly
1116  * 20d float_output_format, with the negative of the C-constant "HUGE"
1117  * from <math.h>.
1118  *
1119  * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
1120  *
1121  * I assume that IEEE-754 format numbers can take 329 bytes for the worst
1122  * case of -1e307 in 20d float_output_format. What is one to do (short of
1123  * re-writing _doprnt to be more sane)?
1124  *                      -wsr
1125  */
1126 
1127 void
1128 float_to_string (buf, data)
1129      unsigned char *buf;
1130      double data;
1131 {
1132   unsigned char *cp;
1133   int width;
1134 
1135   /* Check for plus infinity in a way that won't lose
1136      if there is no plus infinity.  */
1137   if (data == data / 2 && data > 1.0)
1138     {
1139       strcpy (buf, "1.0e+INF");
1140       return;
1141     }
1142   /* Likewise for minus infinity.  */
1143   if (data == data / 2 && data < -1.0)
1144     {
1145       strcpy (buf, "-1.0e+INF");
1146       return;
1147     }
1148   /* Check for NaN in a way that won't fail if there are no NaNs.  */
1149   if (! (data * 0.0 >= 0.0))
1150     {
1151       /* Prepend "-" if the NaN's sign bit is negative.
1152          The sign bit of a double is the bit that is 1 in -0.0.  */
1153       int i;
1154       union { double d; char c[sizeof (double)]; } u_data, u_minus_zero;
1155       u_data.d = data;
1156       u_minus_zero.d = - 0.0;
1157       for (i = 0; i < sizeof (double); i++)
1158         if (u_data.c[i] & u_minus_zero.c[i])
1159           {
1160             *buf++ = '-';
1161             break;
1162           }
1163 
1164       strcpy (buf, "0.0e+NaN");
1165       return;
1166     }
1167 
1168   if (NILP (Vfloat_output_format)
1169       || !STRINGP (Vfloat_output_format))
1170   lose:
1171     {
1172       /* Generate the fewest number of digits that represent the
1173          floating point value without losing information.
1174          The following method is simple but a bit slow.
1175          For ideas about speeding things up, please see:
1176 
1177          Guy L Steele Jr & Jon L White, How to print floating-point numbers
1178          accurately.  SIGPLAN notices 25, 6 (June 1990), 112-126.
1179 
1180          Robert G Burger & R Kent Dybvig, Printing floating point numbers
1181          quickly and accurately, SIGPLAN notices 31, 5 (May 1996), 108-116.  */
1182 
1183       width = fabs (data) < DBL_MIN ? 1 : DBL_DIG;
1184       do
1185         sprintf (buf, "%.*g", width, data);
1186       while (width++ < DOUBLE_DIGITS_BOUND && atof (buf) != data);
1187     }
1188   else                  /* oink oink */
1189     {
1190       /* Check that the spec we have is fully valid.
1191          This means not only valid for printf,
1192          but meant for floats, and reasonable.  */
1193       cp = SDATA (Vfloat_output_format);
1194 
1195       if (cp[0] != '%')
1196         goto lose;
1197       if (cp[1] != '.')
1198         goto lose;
1199 
1200       cp += 2;
1201 
1202       /* Check the width specification.  */
1203       width = -1;
1204       if ('0' <= *cp && *cp <= '9')
1205         {
1206           width = 0;
1207           do
1208             width = (width * 10) + (*cp++ - '0');
1209           while (*cp >= '0' && *cp <= '9');
1210 
1211           /* A precision of zero is valid only for %f.  */
1212           if (width > DBL_DIG
1213               || (width == 0 && *cp != 'f'))
1214             goto lose;
1215         }
1216 
1217       if (*cp != 'e' && *cp != 'f' && *cp != 'g')
1218         goto lose;
1219 
1220       if (cp[1] != 0)
1221         goto lose;
1222 
1223       sprintf (buf, SDATA (Vfloat_output_format), data);
1224     }
1225 
1226   /* Make sure there is a decimal point with digit after, or an
1227      exponent, so that the value is readable as a float.  But don't do
1228      this with "%.0f"; it's valid for that not to produce a decimal
1229      point.  Note that width can be 0 only for %.0f.  */
1230   if (width != 0)
1231     {
1232       for (cp = buf; *cp; cp++)
1233         if ((*cp < '0' || *cp > '9') && *cp != '-')
1234           break;
1235 
1236       if (*cp == '.' && cp[1] == 0)
1237         {
1238           cp[1] = '0';
1239           cp[2] = 0;
1240         }
1241 
1242       if (*cp == 0)
1243         {
1244           *cp++ = '.';
1245           *cp++ = '0';
1246           *cp++ = 0;
1247         }
1248     }
1249 }
1250 
1251 
1252 static void
1253 print (obj, printcharfun, escapeflag)
1254      Lisp_Object obj;
1255      register Lisp_Object printcharfun;
1256      int escapeflag;
1257 {
1258   new_backquote_output = 0;
1259 
1260   /* Reset print_number_index and Vprint_number_table only when
1261      the variable Vprint_continuous_numbering is nil.  Otherwise,
1262      the values of these variables will be kept between several
1263      print functions.  */
1264   if (NILP (Vprint_continuous_numbering)
1265       || NILP (Vprint_number_table))
1266     {
1267       print_number_index = 0;
1268       Vprint_number_table = Qnil;
1269     }
1270 
1271   /* Construct Vprint_number_table for print-gensym and print-circle.  */
1272   if (!NILP (Vprint_gensym) || !NILP (Vprint_circle))
1273     {
1274       int i, start, index;
1275       start = index = print_number_index;
1276       /* Construct Vprint_number_table.
1277          This increments print_number_index for the objects added.  */
1278       print_depth = 0;
1279       print_preprocess (obj);
1280 
1281       /* Remove unnecessary objects, which appear only once in OBJ;
1282          that is, whose status is Qnil.  Compactify the necessary objects.  */
1283       for (i = start; i < print_number_index; i++)
1284         if (!NILP (PRINT_NUMBER_STATUS (Vprint_number_table, i)))
1285           {
1286             PRINT_NUMBER_OBJECT (Vprint_number_table, index)
1287               = PRINT_NUMBER_OBJECT (Vprint_number_table, i);
1288             index++;
1289           }
1290 
1291       /* Clear out objects outside the active part of the table.  */
1292       for (i = index; i < print_number_index; i++)
1293         PRINT_NUMBER_OBJECT (Vprint_number_table, i) = Qnil;
1294 
1295       /* Reset the status field for the next print step.  Now this
1296          field means whether the object has already been printed.  */
1297       for (i = start; i < print_number_index; i++)
1298         PRINT_NUMBER_STATUS (Vprint_number_table, i) = Qnil;
1299 
1300       print_number_index = index;
1301     }
1302 
1303   print_depth = 0;
1304   print_object (obj, printcharfun, escapeflag);
1305 }
1306 
1307 /* Construct Vprint_number_table according to the structure of OBJ.
1308    OBJ itself and all its elements will be added to Vprint_number_table
1309    recursively if it is a list, vector, compiled function, char-table,
1310    string (its text properties will be traced), or a symbol that has
1311    no obarray (this is for the print-gensym feature).
1312    The status fields of Vprint_number_table mean whether each object appears
1313    more than once in OBJ: Qnil at the first time, and Qt after that .  */
1314 static void
1315 print_preprocess (obj)
1316      Lisp_Object obj;
1317 {
1318   int i;
1319   EMACS_INT size;
1320   int loop_count = 0;
1321   Lisp_Object halftail;
1322 
1323   /* Give up if we go so deep that print_object will get an error.  */
1324   /* See similar code in print_object.  */
1325   if (print_depth >= PRINT_CIRCLE)
1326     error ("Apparently circular structure being printed");
1327 
1328   /* Avoid infinite recursion for circular nested structure
1329      in the case where Vprint_circle is nil.  */
1330   if (NILP (Vprint_circle))
1331     {
1332       for (i = 0; i < print_depth; i++)
1333         if (EQ (obj, being_printed[i]))
1334           return;
1335       being_printed[print_depth] = obj;
1336     }
1337 
1338   print_depth++;
1339   halftail = obj;
1340 
1341  loop:
1342   if (STRINGP (obj) || CONSP (obj) || VECTORP (obj)
1343       || COMPILEDP (obj) || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj)
1344       || HASH_TABLE_P (obj)
1345       || (! NILP (Vprint_gensym)
1346           && SYMBOLP (obj)
1347           && !SYMBOL_INTERNED_P (obj)))
1348     {
1349       /* In case print-circle is nil and print-gensym is t,
1350          add OBJ to Vprint_number_table only when OBJ is a symbol.  */
1351       if (! NILP (Vprint_circle) || SYMBOLP (obj))
1352         {
1353           for (i = 0; i < print_number_index; i++)
1354             if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table, i), obj))
1355               {
1356                 /* OBJ appears more than once.  Let's remember that.  */
1357                 PRINT_NUMBER_STATUS (Vprint_number_table, i) = Qt;
1358                 print_depth--;
1359                 return;
1360               }
1361 
1362           /* OBJ is not yet recorded.  Let's add to the table.  */
1363           if (print_number_index == 0)
1364             {
1365               /* Initialize the table.  */
1366               Vprint_number_table = Fmake_vector (make_number (40), Qnil);
1367             }
1368           else if (XVECTOR (Vprint_number_table)->size == print_number_index * 2)
1369             {
1370               /* Reallocate the table.  */
1371               int i = print_number_index * 4;
1372               Lisp_Object old_table = Vprint_number_table;
1373               Vprint_number_table = Fmake_vector (make_number (i), Qnil);
1374               for (i = 0; i < print_number_index; i++)
1375                 {
1376                   PRINT_NUMBER_OBJECT (Vprint_number_table, i)
1377                     = PRINT_NUMBER_OBJECT (old_table, i);
1378                   PRINT_NUMBER_STATUS (Vprint_number_table, i)
1379                     = PRINT_NUMBER_STATUS (old_table, i);
1380                 }
1381             }
1382           PRINT_NUMBER_OBJECT (Vprint_number_table, print_number_index) = obj;
1383           /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1384              always print the gensym with a number.  This is a special for
1385              the lisp function byte-compile-output-docform.  */
1386           if (!NILP (Vprint_continuous_numbering)
1387               && SYMBOLP (obj)
1388               && !SYMBOL_INTERNED_P (obj))
1389             PRINT_NUMBER_STATUS (Vprint_number_table, print_number_index) = Qt;
1390           print_number_index++;
1391         }
1392 
1393       switch (XTYPE (obj))
1394         {
1395         case Lisp_String:
1396           /* A string may have text properties, which can be circular.  */
1397           traverse_intervals_noorder (STRING_INTERVALS (obj),
1398                                       print_preprocess_string, Qnil);
1399           break;
1400 
1401         case Lisp_Cons:
1402           /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1403              just as in print_object.  */
1404           if (loop_count && EQ (obj, halftail))
1405             break;
1406           print_preprocess (XCAR (obj));
1407           obj = XCDR (obj);
1408           loop_count++;
1409           if (!(loop_count & 1))
1410             halftail = XCDR (halftail);
1411           goto loop;
1412 
1413         case Lisp_Vectorlike:
1414           size = XVECTOR (obj)->size;
1415           if (size & PSEUDOVECTOR_FLAG)
1416             size &= PSEUDOVECTOR_SIZE_MASK;
1417           for (i = 0; i < size; i++)
1418             print_preprocess (XVECTOR (obj)->contents[i]);
1419           if (HASH_TABLE_P (obj))
1420             { /* For hash tables, the key_and_value slot is past
1421                 `size' because it needs to be marked specially in case
1422                 the table is weak.  */
1423               struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
1424               print_preprocess (h->key_and_value);
1425             }
1426           break;
1427 
1428         default:
1429           break;
1430         }
1431     }
1432   print_depth--;
1433 }
1434 
1435 static void
1436 print_preprocess_string (interval, arg)
1437      INTERVAL interval;
1438      Lisp_Object arg;
1439 {
1440   print_preprocess (interval->plist);
1441 }
1442 
1443 /* A flag to control printing of `charset' text property.
1444    The default value is Qdefault. */
1445 Lisp_Object Vprint_charset_text_property;
1446 extern Lisp_Object Qdefault;
1447 
1448 static void print_check_string_charset_prop ();
1449 
1450 #define PRINT_STRING_NON_CHARSET_FOUND 1
1451 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1452 
1453 /* Bitwize or of the abobe macros. */
1454 static int print_check_string_result;
1455 
1456 static void
1457 print_check_string_charset_prop (interval, string)
1458      INTERVAL interval;
1459      Lisp_Object string;
1460 {
1461   Lisp_Object val;
1462 
1463   if (NILP (interval->plist)
1464       || (print_check_string_result == (PRINT_STRING_NON_CHARSET_FOUND
1465                                         | PRINT_STRING_UNSAFE_CHARSET_FOUND)))
1466     return;
1467   for (val = interval->plist; CONSP (val) && ! EQ (XCAR (val), Qcharset);
1468        val = XCDR (XCDR (val)));
1469   if (! CONSP (val))
1470     {
1471       print_check_string_result |= PRINT_STRING_NON_CHARSET_FOUND;
1472       return;
1473     }
1474   if (! (print_check_string_result & PRINT_STRING_NON_CHARSET_FOUND))
1475     {
1476       if (! EQ (val, interval->plist)
1477           || CONSP (XCDR (XCDR (val))))
1478         print_check_string_result |= PRINT_STRING_NON_CHARSET_FOUND;
1479     }
1480   if (NILP (Vprint_charset_text_property)
1481       || ! (print_check_string_result & PRINT_STRING_UNSAFE_CHARSET_FOUND))
1482     {
1483       int i, c;
1484       int charpos = interval->position;
1485       int bytepos = string_char_to_byte (string, charpos);
1486       Lisp_Object charset;
1487 
1488       charset = XCAR (XCDR (val));
1489       for (i = 0; i < LENGTH (interval); i++)
1490         {
1491           FETCH_STRING_CHAR_ADVANCE (c, string, charpos, bytepos);
1492           if (! ASCII_CHAR_P (c)
1493               && ! EQ (CHARSET_NAME (CHAR_CHARSET (c)), charset))
1494             {
1495               print_check_string_result |= PRINT_STRING_UNSAFE_CHARSET_FOUND;
1496               break;
1497             }
1498         }
1499     }
1500 }
1501 
1502 /* The value is (charset . nil).  */
1503 static Lisp_Object print_prune_charset_plist;
1504 
1505 static Lisp_Object
1506 print_prune_string_charset (string)
1507      Lisp_Object string;
1508 {
1509   print_check_string_result = 0;
1510   traverse_intervals (STRING_INTERVALS (string), 0,
1511                       print_check_string_charset_prop, string);
1512   if (! (print_check_string_result & PRINT_STRING_UNSAFE_CHARSET_FOUND))
1513     {
1514       string = Fcopy_sequence (string);
1515       if (print_check_string_result & PRINT_STRING_NON_CHARSET_FOUND)
1516         {
1517           if (NILP (print_prune_charset_plist))
1518             print_prune_charset_plist = Fcons (Qcharset, Qnil);
1519           Fremove_text_properties (make_number (0),
1520                                    make_number (SCHARS (string)),
1521                                    print_prune_charset_plist, string);
1522         }
1523       else
1524         Fset_text_properties (make_number (0), make_number (SCHARS (string)),
1525                               Qnil, string);
1526     }
1527   return string;
1528 }
1529 
1530 static void
1531 print_object (obj, printcharfun, escapeflag)
1532      Lisp_Object obj;
1533      register Lisp_Object printcharfun;
1534      int escapeflag;
1535 {
1536   char buf[40];
1537 
1538   QUIT;
1539 
1540   /* See similar code in print_preprocess.  */
1541   if (print_depth >= PRINT_CIRCLE)
1542     error ("Apparently circular structure being printed");
1543 
1544   /* Detect circularities and truncate them.  */
1545   if (STRINGP (obj) || CONSP (obj) || VECTORP (obj)
1546       || COMPILEDP (obj) || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj)
1547       || HASH_TABLE_P (obj)
1548       || (! NILP (Vprint_gensym)
1549           && SYMBOLP (obj)
1550           && !SYMBOL_INTERNED_P (obj)))
1551     {
1552       if (NILP (Vprint_circle) && NILP (Vprint_gensym))
1553         {
1554           /* Simple but incomplete way.  */
1555           int i;
1556           for (i = 0; i < print_depth; i++)
1557             if (EQ (obj, being_printed[i]))
1558               {
1559                 sprintf (buf, "#%d", i);
1560                 strout (buf, -1, -1, printcharfun, 0);
1561                 return;
1562               }
1563           being_printed[print_depth] = obj;
1564         }
1565       else
1566         {
1567           /* With the print-circle feature.  */
1568           int i;
1569           for (i = 0; i < print_number_index; i++)
1570             if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table, i), obj))
1571               {
1572                 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table, i)))
1573                   {
1574                     /* Add a prefix #n= if OBJ has not yet been printed;
1575                        that is, its status field is nil.  */
1576                     sprintf (buf, "#%d=", i + 1);
1577                     strout (buf, -1, -1, printcharfun, 0);
1578                     /* OBJ is going to be printed.  Set the status to t.  */
1579                     PRINT_NUMBER_STATUS (Vprint_number_table, i) = Qt;
1580                     break;
1581                   }
1582                 else
1583                   {
1584                     /* Just print #n# if OBJ has already been printed.  */
1585                     sprintf (buf, "#%d#", i + 1);
1586                     strout (buf, -1, -1, printcharfun, 0);
1587                     return;
1588                   }
1589               }
1590         }
1591     }
1592 
1593   print_depth++;
1594 
1595   switch (XTYPE (obj))
1596     {
1597     case_Lisp_Int:
1598       if (sizeof (int) == sizeof (EMACS_INT))
1599         sprintf (buf, "%d", (int) XINT (obj));
1600       else if (sizeof (long) == sizeof (EMACS_INT))
1601         sprintf (buf, "%ld", (long) XINT (obj));
1602       else
1603         abort ();
1604       strout (buf, -1, -1, printcharfun, 0);
1605       break;
1606 
1607     case Lisp_Float:
1608       {
1609         char pigbuf[350];       /* see comments in float_to_string */
1610 
1611         float_to_string (pigbuf, XFLOAT_DATA (obj));
1612         strout (pigbuf, -1, -1, printcharfun, 0);
1613       }
1614       break;
1615 
1616     case Lisp_String:
1617       if (!escapeflag)
1618         print_string (obj, printcharfun);
1619       else
1620         {
1621           register int i, i_byte;
1622           struct gcpro gcpro1;
1623           unsigned char *str;
1624           int size_byte;
1625           /* 1 means we must ensure that the next character we output
1626              cannot be taken as part of a hex character escape.  */
1627           int need_nonhex = 0;
1628           int multibyte = STRING_MULTIBYTE (obj);
1629 
1630           GCPRO1 (obj);
1631 
1632           if (! EQ (Vprint_charset_text_property, Qt))
1633             obj = print_prune_string_charset (obj);
1634 
1635           if (!NULL_INTERVAL_P (STRING_INTERVALS (obj)))
1636             {
1637               PRINTCHAR ('#');
1638               PRINTCHAR ('(');
1639             }
1640 
1641           PRINTCHAR ('\"');
1642           str = SDATA (obj);
1643           size_byte = SBYTES (obj);
1644 
1645           for (i = 0, i_byte = 0; i_byte < size_byte;)
1646             {
1647               /* Here, we must convert each multi-byte form to the
1648                  corresponding character code before handing it to PRINTCHAR.  */
1649               int len;
1650               int c;
1651 
1652               if (multibyte)
1653                 {
1654                   c = STRING_CHAR_AND_LENGTH (str + i_byte, len);
1655                   i_byte += len;
1656                 }
1657               else
1658                 c = str[i_byte++];
1659 
1660               QUIT;
1661 
1662               if (c == '\n' && print_escape_newlines)
1663                 {
1664                   PRINTCHAR ('\\');
1665                   PRINTCHAR ('n');
1666                 }
1667               else if (c == '\f' && print_escape_newlines)
1668                 {
1669                   PRINTCHAR ('\\');
1670                   PRINTCHAR ('f');
1671                 }
1672               else if (multibyte
1673                        && (CHAR_BYTE8_P (c) 
1674                            || (! ASCII_CHAR_P (c) && print_escape_multibyte)))
1675                 {
1676                   /* When multibyte is disabled,
1677                      print multibyte string chars using hex escapes.
1678                      For a char code that could be in a unibyte string,
1679                      when found in a multibyte string, always use a hex escape
1680                      so it reads back as multibyte.  */
1681                   unsigned char outbuf[50];
1682 
1683                   if (CHAR_BYTE8_P (c))
1684                     sprintf (outbuf, "\\%03o", CHAR_TO_BYTE8 (c));
1685                   else
1686                     {
1687                       sprintf (outbuf, "\\x%04x", c);
1688                       need_nonhex = 1;
1689                     }
1690                   strout (outbuf, -1, -1, printcharfun, 0);
1691                 }
1692               else if (! multibyte
1693                        && SINGLE_BYTE_CHAR_P (c) && ! ASCII_BYTE_P (c)
1694                        && print_escape_nonascii)
1695                 {
1696                   /* When printing in a multibyte buffer
1697                      or when explicitly requested,
1698                      print single-byte non-ASCII string chars
1699                      using octal escapes.  */
1700                   unsigned char outbuf[5];
1701                   sprintf (outbuf, "\\%03o", c);
1702                   strout (outbuf, -1, -1, printcharfun, 0);
1703                 }
1704               else
1705                 {
1706                   /* If we just had a hex escape, and this character
1707                      could be taken as part of it,
1708                      output `\ ' to prevent that.  */
1709                   if (need_nonhex)
1710                     {
1711                       need_nonhex = 0;
1712                       if ((c >= 'a' && c <= 'f')
1713                           || (c >= 'A' && c <= 'F')
1714                           || (c >= '0' && c <= '9'))
1715                         strout ("\\ ", -1, -1, printcharfun, 0);
1716                     }
1717 
1718                   if (c == '\"' || c == '\\')
1719                     PRINTCHAR ('\\');
1720                   PRINTCHAR (c);
1721                 }
1722             }
1723           PRINTCHAR ('\"');
1724 
1725           if (!NULL_INTERVAL_P (STRING_INTERVALS (obj)))
1726             {
1727               traverse_intervals (STRING_INTERVALS (obj),
1728                                   0, print_interval, printcharfun);
1729               PRINTCHAR (')');
1730             }
1731 
1732           UNGCPRO;
1733         }
1734       break;
1735 
1736     case Lisp_Symbol:
1737       {
1738         register int confusing;
1739         register unsigned char *p = SDATA (SYMBOL_NAME (obj));
1740         register unsigned char *end = p + SBYTES (SYMBOL_NAME (obj));
1741         register int c;
1742         int i, i_byte, size_byte;
1743         Lisp_Object name;
1744 
1745         name = SYMBOL_NAME (obj);
1746 
1747         if (p != end && (*p == '-' || *p == '+')) p++;
1748         if (p == end)
1749           confusing = 0;
1750         /* If symbol name begins with a digit, and ends with a digit,
1751            and contains nothing but digits and `e', it could be treated
1752            as a number.  So set CONFUSING.
1753 
1754            Symbols that contain periods could also be taken as numbers,
1755            but periods are always escaped, so we don't have to worry
1756            about them here.  */
1757         else if (*p >= '0' && *p <= '9'
1758                  && end[-1] >= '0' && end[-1] <= '9')
1759           {
1760             while (p != end && ((*p >= '0' && *p <= '9')
1761                                 /* Needed for \2e10.  */
1762                                 || *p == 'e' || *p == 'E'))
1763               p++;
1764             confusing = (end == p);
1765           }
1766         else
1767           confusing = 0;
1768 
1769         if (! NILP (Vprint_gensym) && !SYMBOL_INTERNED_P (obj))
1770           {
1771             PRINTCHAR ('#');
1772             PRINTCHAR (':');
1773           }
1774 
1775         size_byte = SBYTES (name);
1776 
1777         for (i = 0, i_byte = 0; i_byte < size_byte;)
1778           {
1779             /* Here, we must convert each multi-byte form to the
1780                corresponding character code before handing it to PRINTCHAR.  */
1781             FETCH_STRING_CHAR_ADVANCE (c, name, i, i_byte);
1782             QUIT;
1783 
1784             if (escapeflag)
1785               {
1786                 if (c == '\"' || c == '\\' || c == '\''
1787                     || c == ';' || c == '#' || c == '(' || c == ')'
1788                     || c == ',' || c =='.' || c == '`'
1789                     || c == '[' || c == ']' || c == '?' || c <= 040
1790                     || confusing)
1791                   PRINTCHAR ('\\'), confusing = 0;
1792               }
1793             PRINTCHAR (c);
1794           }
1795       }
1796       break;
1797 
1798     case Lisp_Cons:
1799       /* If deeper than spec'd depth, print placeholder.  */
1800       if (INTEGERP (Vprint_level)
1801           && print_depth > XINT (Vprint_level))
1802         strout ("...", -1, -1, printcharfun, 0);
1803       else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
1804                && (EQ (XCAR (obj), Qquote)))
1805         {
1806           PRINTCHAR ('\'');
1807           print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
1808         }
1809       else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
1810                && (EQ (XCAR (obj), Qfunction)))
1811         {
1812           PRINTCHAR ('#');
1813           PRINTCHAR ('\'');
1814           print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
1815         }
1816       else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
1817                && ((EQ (XCAR (obj), Qbackquote))))
1818         {
1819           print_object (XCAR (obj), printcharfun, 0);
1820           new_backquote_output++;
1821           print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
1822           new_backquote_output--;
1823         }
1824       else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
1825                && new_backquote_output
1826                && ((EQ (XCAR (obj), Qbackquote)
1827                     || EQ (XCAR (obj), Qcomma)
1828                     || EQ (XCAR (obj), Qcomma_at)
1829                     || EQ (XCAR (obj), Qcomma_dot))))
1830         {
1831           print_object (XCAR (obj), printcharfun, 0);
1832           new_backquote_output--;
1833           print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
1834           new_backquote_output++;
1835         }
1836       else
1837         {
1838           PRINTCHAR ('(');
1839 
1840           /* If the first element is a backquote form,
1841              print it old-style so it won't be misunderstood.  */
1842           if (print_quoted && CONSP (XCAR (obj))
1843               && CONSP (XCDR (XCAR (obj)))
1844               && NILP (XCDR (XCDR (XCAR (obj))))
1845               && EQ (XCAR (XCAR (obj)), Qbackquote))
1846             {
1847               Lisp_Object tem;
1848               tem = XCAR (obj);
1849               PRINTCHAR ('(');
1850 
1851               print_object (Qbackquote, printcharfun, 0);
1852               PRINTCHAR (' ');
1853 
1854               print_object (XCAR (XCDR (tem)), printcharfun, 0);
1855               PRINTCHAR (')');
1856 
1857               obj = XCDR (obj);
1858             }
1859 
1860           {
1861             int print_length, i;
1862             Lisp_Object halftail = obj;
1863 
1864             /* Negative values of print-length are invalid in CL.
1865                Treat them like nil, as CMUCL does.  */
1866             if (NATNUMP (Vprint_length))
1867               print_length = XFASTINT (Vprint_length);
1868             else
1869               print_length = 0;
1870 
1871             i = 0;
1872             while (CONSP (obj))
1873               {
1874                 /* Detect circular list.  */
1875                 if (NILP (Vprint_circle))
1876                   {
1877                     /* Simple but imcomplete way.  */
1878                     if (i != 0 && EQ (obj, halftail))
1879                       {
1880                         sprintf (buf, " . #%d", i / 2);
1881                         strout (buf, -1, -1, printcharfun, 0);
1882                         goto end_of_list;
1883                       }
1884                   }
1885                 else
1886                   {
1887                     /* With the print-circle feature.  */
1888                     if (i != 0)
1889                       {
1890                         int i;
1891                         for (i = 0; i < print_number_index; i++)
1892                           if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table, i),
1893                                   obj))
1894                             {
1895                               if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table, i)))
1896                                 {
1897                                   strout (" . ", 3, 3, printcharfun, 0);
1898                                   print_object (obj, printcharfun, escapeflag);
1899                                 }
1900                               else
1901                                 {
1902                                   sprintf (buf, " . #%d#", i + 1);
1903                                   strout (buf, -1, -1, printcharfun, 0);
1904                                 }
1905                               goto end_of_list;
1906                             }
1907                       }
1908                   }
1909 
1910                 if (i++)
1911                   PRINTCHAR (' ');
1912 
1913                 if (print_length && i > print_length)
1914                   {
1915                     strout ("...", 3, 3, printcharfun, 0);
1916                     goto end_of_list;
1917                   }
1918 
1919                 print_object (XCAR (obj), printcharfun, escapeflag);
1920 
1921                 obj = XCDR (obj);
1922                 if (!(i & 1))
1923                   halftail = XCDR (halftail);
1924               }
1925           }
1926 
1927           /* OBJ non-nil here means it's the end of a dotted list.  */
1928           if (!NILP (obj))
1929             {
1930               strout (" . ", 3, 3, printcharfun, 0);
1931               print_object (obj, printcharfun, escapeflag);
1932             }
1933 
1934         end_of_list:
1935           PRINTCHAR (')');
1936         }
1937       break;
1938 
1939     case Lisp_Vectorlike:
1940       if (PROCESSP (obj))
1941         {
1942           if (escapeflag)
1943             {
1944               strout ("#<process ", -1, -1, printcharfun, 0);
1945               print_string (XPROCESS (obj)->name, printcharfun);
1946               PRINTCHAR ('>');
1947             }
1948           else
1949             print_string (XPROCESS (obj)->name, printcharfun);
1950         }
1951       else if (BOOL_VECTOR_P (obj))
1952         {
1953           register int i;
1954           register unsigned char c;
1955           struct gcpro gcpro1;
1956           int size_in_chars
1957             = ((XBOOL_VECTOR (obj)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
1958                / BOOL_VECTOR_BITS_PER_CHAR);
1959 
1960           GCPRO1 (obj);
1961 
1962           PRINTCHAR ('#');
1963           PRINTCHAR ('&');
1964           sprintf (buf, "%ld", (long) XBOOL_VECTOR (obj)->size);
1965           strout (buf, -1, -1, printcharfun, 0);
1966           PRINTCHAR ('\"');
1967 
1968           /* Don't print more characters than the specified maximum.
1969              Negative values of print-length are invalid.  Treat them
1970              like a print-length of nil.  */
1971           if (NATNUMP (Vprint_length)
1972               && XFASTINT (Vprint_length) < size_in_chars)
1973             size_in_chars = XFASTINT (Vprint_length);
1974 
1975           for (i = 0; i < size_in_chars; i++)
1976             {
1977               QUIT;
1978               c = XBOOL_VECTOR (obj)->data[i];
1979               if (c == '\n' && print_escape_newlines)
1980                 {
1981                   PRINTCHAR ('\\');
1982                   PRINTCHAR ('n');
1983                 }
1984               else if (c == '\f' && print_escape_newlines)
1985                 {
1986                   PRINTCHAR ('\\');
1987                   PRINTCHAR ('f');
1988                 }
1989               else if (c > '\177')
1990                 {
1991                   /* Use octal escapes to avoid encoding issues.  */
1992                   PRINTCHAR ('\\');
1993                   PRINTCHAR ('0' + ((c >> 6) & 3));
1994                   PRINTCHAR ('0' + ((c >> 3) & 7));
1995                   PRINTCHAR ('0' + (c & 7));
1996                 }
1997               else
1998                 {
1999                   if (c == '\"' || c == '\\')
2000                     PRINTCHAR ('\\');
2001                   PRINTCHAR (c);
2002                 }
2003             }
2004           PRINTCHAR ('\"');
2005 
2006           UNGCPRO;
2007         }
2008       else if (SUBRP (obj))
2009         {
2010           strout ("#<subr ", -1, -1, printcharfun, 0);
2011           strout (XSUBR (obj)->symbol_name, -1, -1, printcharfun, 0);
2012           PRINTCHAR ('>');
2013         }
2014       else if (WINDOWP (obj))
2015         {
2016           strout ("#<window ", -1, -1, printcharfun, 0);
2017           sprintf (buf, "%ld", (long) XFASTINT (XWINDOW (obj)->sequence_number));
2018           strout (buf, -1, -1, printcharfun, 0);
2019           if (!NILP (XWINDOW (obj)->buffer))
2020             {
2021               strout (" on ", -1, -1, printcharfun, 0);
2022               print_string (XBUFFER (XWINDOW (obj)->buffer)->name, printcharfun);
2023             }
2024           PRINTCHAR ('>');
2025         }
2026       else if (TERMINALP (obj))
2027         {
2028           struct terminal *t = XTERMINAL (obj);
2029           strout ("#<terminal ", -1, -1, printcharfun, 0);
2030           sprintf (buf, "%d", t->id);
2031           strout (buf, -1, -1, printcharfun, 0);
2032           if (t->name)
2033             {
2034               strout (" on ", -1, -1, printcharfun, 0);
2035               strout (t->name, -1, -1, printcharfun, 0);
2036             }
2037           PRINTCHAR ('>');
2038         }
2039       else if (HASH_TABLE_P (obj))
2040         {
2041           struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
2042           int i, real_size, size;
2043 #if 0
2044           strout ("#<hash-table", -1, -1, printcharfun, 0);
2045           if (SYMBOLP (h->test))
2046             {
2047               PRINTCHAR (' ');
2048               PRINTCHAR ('\'');
2049               strout (SDATA (SYMBOL_NAME (h->test)), -1, -1, printcharfun, 0);
2050               PRINTCHAR (' ');
2051               strout (SDATA (SYMBOL_NAME (h->weak)), -1, -1, printcharfun, 0);
2052               PRINTCHAR (' ');
2053               sprintf (buf, "%ld/%ld", (long) h->count,
2054                        (long) XVECTOR (h->next)->size);
2055               strout (buf, -1, -1, printcharfun, 0);
2056             }
2057           sprintf (buf, " 0x%lx", (unsigned long) h);
2058           strout (buf, -1, -1, printcharfun, 0);
2059           PRINTCHAR ('>');
2060 #endif
2061           /* Implement a readable output, e.g.:
2062             #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
2063           /* Always print the size. */
2064           sprintf (buf, "#s(hash-table size %ld",
2065                    (long) XVECTOR (h->next)->size);
2066           strout (buf, -1, -1, printcharfun, 0);
2067 
2068           if (!NILP (h->test))
2069             {
2070               strout (" test ", -1, -1, printcharfun, 0);
2071               print_object (h->test, printcharfun, 0);
2072             }
2073 
2074           if (!NILP (h->weak))
2075             {
2076               strout (" weakness ", -1, -1, printcharfun, 0);
2077               print_object (h->weak, printcharfun, 0);
2078             }
2079 
2080           if (!NILP (h->rehash_size))
2081             {
2082               strout (" rehash-size ", -1, -1, printcharfun, 0);
2083               print_object (h->rehash_size, printcharfun, 0);
2084             }
2085 
2086           if (!NILP (h->rehash_threshold))
2087             {
2088               strout (" rehash-threshold ", -1, -1, printcharfun, 0);
2089               print_object (h->rehash_threshold, printcharfun, 0);
2090             }
2091 
2092           strout (" data ", -1, -1, printcharfun, 0);
2093 
2094           /* Print the data here as a plist. */
2095           real_size = HASH_TABLE_SIZE (h);
2096           size = real_size;
2097 
2098           /* Don't print more elements than the specified maximum.  */
2099           if (NATNUMP (Vprint_length)
2100               && XFASTINT (Vprint_length) < size)
2101             size = XFASTINT (Vprint_length);
2102           
2103           PRINTCHAR ('(');
2104           for (i = 0; i < size; i++)
2105             if (!NILP (HASH_HASH (h, i)))
2106               {
2107                 if (i) PRINTCHAR (' ');
2108                 print_object (HASH_KEY (h, i), printcharfun, 1);
2109                 PRINTCHAR (' ');
2110                 print_object (HASH_VALUE (h, i), printcharfun, 1);
2111               }
2112 
2113           if (size < real_size)
2114             strout (" ...", 4, 4, printcharfun, 0);
2115 
2116           PRINTCHAR (')');
2117           PRINTCHAR (')');
2118 
2119         }
2120       else if (BUFFERP (obj))
2121         {
2122           if (NILP (XBUFFER (obj)->name))
2123             strout ("#<killed buffer>", -1, -1, printcharfun, 0);
2124           else if (escapeflag)
2125             {
2126               strout ("#<buffer ", -1, -1, printcharfun, 0);
2127               print_string (XBUFFER (obj)->name, printcharfun);
2128               PRINTCHAR ('>');
2129             }
2130           else
2131             print_string (XBUFFER (obj)->name, printcharfun);
2132         }
2133       else if (WINDOW_CONFIGURATIONP (obj))
2134         {
2135           strout ("#<window-configuration>", -1, -1, printcharfun, 0);
2136         }
2137       else if (FRAMEP (obj))
2138         {
2139           strout ((FRAME_LIVE_P (XFRAME (obj))
2140                    ? "#<frame " : "#<dead frame "),
2141                   -1, -1, printcharfun, 0);
2142           print_string (XFRAME (obj)->name, printcharfun);
2143           sprintf (buf, " 0x%lx", (unsigned long) (XFRAME (obj)));
2144           strout (buf, -1, -1, printcharfun, 0);
2145           PRINTCHAR ('>');
2146         }
2147       else if (FONTP (obj))
2148         {
2149           EMACS_INT i;
2150 
2151           if (! FONT_OBJECT_P (obj))
2152             {
2153               if (FONT_SPEC_P (obj))
2154                 strout ("#<font-spec", -1, -1, printcharfun, 0);
2155               else
2156                 strout ("#<font-entity", -1, -1, printcharfun, 0);
2157               for (i = 0; i < FONT_SPEC_MAX; i++)
2158                 {
2159                   PRINTCHAR (' ');
2160                   if (i < FONT_WEIGHT_INDEX || i > FONT_WIDTH_INDEX)
2161                     print_object (AREF (obj, i), printcharfun, escapeflag);
2162                   else
2163                     print_object (font_style_symbolic (obj, i, 0),
2164                                   printcharfun, escapeflag);
2165                 }
2166             }
2167           else
2168             {
2169               strout ("#<font-object ", -1, -1, printcharfun, 0);
2170               print_object (AREF (obj, FONT_NAME_INDEX), printcharfun,
2171                             escapeflag);
2172             }
2173           PRINTCHAR ('>');
2174         }
2175       else
2176         {
2177           EMACS_INT size = XVECTOR (obj)->size;
2178           if (COMPILEDP (obj))
2179             {
2180               PRINTCHAR ('#');
2181               size &= PSEUDOVECTOR_SIZE_MASK;
2182             }
2183           if (CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj))
2184             {
2185               /* We print a char-table as if it were a vector,
2186                  lumping the parent and default slots in with the
2187                  character slots.  But we add #^ as a prefix.  */
2188 
2189               /* Make each lowest sub_char_table start a new line.
2190                  Otherwise we'll make a line extremely long, which
2191                  results in slow redisplay.  */
2192               if (SUB_CHAR_TABLE_P (obj)
2193                   && XINT (XSUB_CHAR_TABLE (obj)->depth) == 3)
2194                 PRINTCHAR ('\n');
2195               PRINTCHAR ('#');
2196               PRINTCHAR ('^');
2197               if (SUB_CHAR_TABLE_P (obj))
2198                 PRINTCHAR ('^');
2199               size &= PSEUDOVECTOR_SIZE_MASK;
2200             }
2201           if (size & PSEUDOVECTOR_FLAG)
2202             goto badtype;
2203 
2204           PRINTCHAR ('[');
2205           {
2206             register int i;
2207             register Lisp_Object tem;
2208             int real_size = size;
2209 
2210             /* Don't print more elements than the specified maximum.  */
2211             if (NATNUMP (Vprint_length)
2212                 && XFASTINT (Vprint_length) < size)
2213               size = XFASTINT (Vprint_length);
2214 
2215             for (i = 0; i < size; i++)
2216               {
2217                 if (i) PRINTCHAR (' ');
2218                 tem = XVECTOR (obj)->contents[i];
2219                 print_object (tem, printcharfun, escapeflag);
2220               }
2221             if (size < real_size)
2222               strout (" ...", 4, 4, printcharfun, 0);
2223           }
2224           PRINTCHAR (']');
2225         }
2226       break;
2227 
2228     case Lisp_Misc:
2229       switch (XMISCTYPE (obj))
2230         {
2231         case Lisp_Misc_Marker:
2232           strout ("#<marker ", -1, -1, printcharfun, 0);
2233           /* Do you think this is necessary?  */
2234           if (XMARKER (obj)->insertion_type != 0)
2235             strout ("(moves after insertion) ", -1, -1, printcharfun, 0);
2236           if (! XMARKER (obj)->buffer)
2237             strout ("in no buffer", -1, -1, printcharfun, 0);
2238           else
2239             {
2240               sprintf (buf, "at %d", marker_position (obj));
2241               strout (buf, -1, -1, printcharfun, 0);
2242               strout (" in ", -1, -1, printcharfun, 0);
2243               print_string (XMARKER (obj)->buffer->name, printcharfun);
2244             }
2245           PRINTCHAR ('>');
2246           break;
2247 
2248         case Lisp_Misc_Overlay:
2249           strout ("#<overlay ", -1, -1, printcharfun, 0);
2250           if (! XMARKER (OVERLAY_START (obj))->buffer)
2251             strout ("in no buffer", -1, -1, printcharfun, 0);
2252           else
2253             {
2254               sprintf (buf, "from %d to %d in ",
2255                        marker_position (OVERLAY_START (obj)),
2256                        marker_position (OVERLAY_END   (obj)));
2257               strout (buf, -1, -1, printcharfun, 0);
2258               print_string (XMARKER (OVERLAY_START (obj))->buffer->name,
2259                             printcharfun);
2260             }
2261           PRINTCHAR ('>');
2262           break;
2263 
2264       /* Remaining cases shouldn't happen in normal usage, but let's print
2265          them anyway for the benefit of the debugger.  */
2266         case Lisp_Misc_Free:
2267           strout ("#<misc free cell>", -1, -1, printcharfun, 0);
2268           break;
2269 
2270         case Lisp_Misc_Save_Value:
2271           strout ("#<save_value ", -1, -1, printcharfun, 0);
2272           sprintf(buf, "ptr=0x%08lx int=%d",
2273                   (unsigned long) XSAVE_VALUE (obj)->pointer,
2274                   XSAVE_VALUE (obj)->integer);
2275           strout (buf, -1, -1, printcharfun, 0);
2276           PRINTCHAR ('>');
2277           break;
2278 
2279         default:
2280           goto badtype;
2281         }
2282       break;
2283 
2284     default:
2285     badtype:
2286       {
2287         /* We're in trouble if this happens!
2288            Probably should just abort () */
2289         strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun, 0);
2290         if (MISCP (obj))
2291           sprintf (buf, "(MISC 0x%04x)", (int) XMISCTYPE (obj));
2292         else if (VECTORLIKEP (obj))
2293           sprintf (buf, "(PVEC 0x%08x)", (int) XVECTOR (obj)->size);
2294         else
2295           sprintf (buf, "(0x%02x)", (int) XTYPE (obj));
2296         strout (buf, -1, -1, printcharfun, 0);
2297         strout (" Save your buffers immediately and please report this bug>",
2298                 -1, -1, printcharfun, 0);
2299       }
2300     }
2301 
2302   print_depth--;
2303 }
2304 
2305 
2306 /* Print a description of INTERVAL using PRINTCHARFUN.
2307    This is part of printing a string that has text properties.  */
2308 
2309 void
2310 print_interval (interval, printcharfun)
2311      INTERVAL interval;
2312      Lisp_Object printcharfun;
2313 {
2314   if (NILP (interval->plist))
2315     return;
2316   PRINTCHAR (' ');
2317   print_object (make_number (interval->position), printcharfun, 1);
2318   PRINTCHAR (' ');
2319   print_object (make_number (interval->position + LENGTH (interval)),
2320                 printcharfun, 1);
2321   PRINTCHAR (' ');
2322   print_object (interval->plist, printcharfun, 1);
2323 }
2324 
2325 
2326 void
2327 syms_of_print ()
2328 {
2329   Qtemp_buffer_setup_hook = intern_c_string ("temp-buffer-setup-hook");
2330   staticpro (&Qtemp_buffer_setup_hook);
2331 
2332   DEFVAR_LISP ("standard-output", &Vstandard_output,
2333                doc: /* Output stream `print' uses by default for outputting a character.
2334 This may be any function of one argument.
2335 It may also be a buffer (output is inserted before point)
2336 or a marker (output is inserted and the marker is advanced)
2337 or the symbol t (output appears in the echo area).  */);
2338   Vstandard_output = Qt;
2339   Qstandard_output = intern_c_string ("standard-output");
2340   staticpro (&Qstandard_output);
2341 
2342   DEFVAR_LISP ("float-output-format", &Vfloat_output_format,
2343                doc: /* The format descriptor string used to print floats.
2344 This is a %-spec like those accepted by `printf' in C,
2345 but with some restrictions.  It must start with the two characters `%.'.
2346 After that comes an integer precision specification,
2347 and then a letter which controls the format.
2348 The letters allowed are `e', `f' and `g'.
2349 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2350 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2351 Use `g' to choose the shorter of those two formats for the number at hand.
2352 The precision in any of these cases is the number of digits following
2353 the decimal point.  With `f', a precision of 0 means to omit the
2354 decimal point.  0 is not allowed with `e' or `g'.
2355 
2356 A value of nil means to use the shortest notation
2357 that represents the number without losing information.  */);
2358   Vfloat_output_format = Qnil;
2359   Qfloat_output_format = intern_c_string ("float-output-format");
2360   staticpro (&Qfloat_output_format);
2361 
2362   DEFVAR_LISP ("print-length", &Vprint_length,
2363                doc: /* Maximum length of list to print before abbreviating.
2364 A value of nil means no limit.  See also `eval-expression-print-length'.  */);
2365   Vprint_length = Qnil;
2366 
2367   DEFVAR_LISP ("print-level", &Vprint_level,
2368                doc: /* Maximum depth of list nesting to print before abbreviating.
2369 A value of nil means no limit.  See also `eval-expression-print-level'.  */);
2370   Vprint_level = Qnil;
2371 
2372   DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines,
2373                doc: /* Non-nil means print newlines in strings as `\\n'.
2374 Also print formfeeds as `\\f'.  */);
2375   print_escape_newlines = 0;
2376 
2377   DEFVAR_BOOL ("print-escape-nonascii", &print_escape_nonascii,
2378                doc: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2379 \(OOO is the octal representation of the character code.)
2380 Only single-byte characters are affected, and only in `prin1'.
2381 When the output goes in a multibyte buffer, this feature is
2382 enabled regardless of the value of the variable.  */);
2383   print_escape_nonascii = 0;
2384 
2385   DEFVAR_BOOL ("print-escape-multibyte", &print_escape_multibyte,
2386                doc: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2387 \(XXXX is the hex representation of the character code.)
2388 This affects only `prin1'.  */);
2389   print_escape_multibyte = 0;
2390 
2391   DEFVAR_BOOL ("print-quoted", &print_quoted,
2392                doc: /* Non-nil means print quoted forms with reader syntax.
2393 I.e., (quote foo) prints as 'foo, (function foo) as #'foo.  */);
2394   print_quoted = 0;
2395 
2396   DEFVAR_LISP ("print-gensym", &Vprint_gensym,
2397                doc: /* Non-nil means print uninterned symbols so they will read as uninterned.
2398 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2399 When the uninterned symbol appears within a recursive data structure,
2400 and the symbol appears more than once, in addition use the #N# and #N=
2401 constructs as needed, so that multiple references to the same symbol are
2402 shared once again when the text is read back.  */);
2403   Vprint_gensym = Qnil;
2404 
2405   DEFVAR_LISP ("print-circle", &Vprint_circle,
2406                doc: /* *Non-nil means print recursive structures using #N= and #N# syntax.
2407 If nil, printing proceeds recursively and may lead to
2408 `max-lisp-eval-depth' being exceeded or an error may occur:
2409 \"Apparently circular structure being printed.\"  Also see
2410 `print-length' and `print-level'.
2411 If non-nil, shared substructures anywhere in the structure are printed
2412 with `#N=' before the first occurrence (in the order of the print
2413 representation) and `#N#' in place of each subsequent occurrence,
2414 where N is a positive decimal integer.  */);
2415   Vprint_circle = Qnil;
2416 
2417   DEFVAR_LISP ("print-continuous-numbering", &Vprint_continuous_numbering,
2418                doc: /* *Non-nil means number continuously across print calls.
2419 This affects the numbers printed for #N= labels and #M# references.
2420 See also `print-circle', `print-gensym', and `print-number-table'.
2421 This variable should not be set with `setq'; bind it with a `let' instead.  */);
2422   Vprint_continuous_numbering = Qnil;
2423 
2424   DEFVAR_LISP ("print-number-table", &Vprint_number_table,
2425                doc: /* A vector used internally to produce `#N=' labels and `#N#' references.
2426 The Lisp printer uses this vector to detect Lisp objects referenced more
2427 than once.
2428 
2429 When you bind `print-continuous-numbering' to t, you should probably
2430 also bind `print-number-table' to nil.  This ensures that the value of
2431 `print-number-table' can be garbage-collected once the printing is
2432 done.  If all elements of `print-number-table' are nil, it means that
2433 the printing done so far has not found any shared structure or objects
2434 that need to be recorded in the table.  */);
2435   Vprint_number_table = Qnil;
2436 
2437   DEFVAR_LISP ("print-charset-text-property", &Vprint_charset_text_property,
2438                doc: /* A flag to control printing of `charset' text property on printing a string.
2439 The value must be nil, t, or `default'.
2440 
2441 If the value is nil, don't print the text property `charset'.
2442 
2443 If the value is t, always print the text property `charset'.
2444 
2445 If the value is `default', print the text property `charset' only when
2446 the value is different from what is guessed in the current charset
2447 priorities.  */);
2448   Vprint_charset_text_property = Qdefault;
2449 
2450   /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2451   staticpro (&Vprin1_to_string_buffer);
2452 
2453   defsubr (&Sprin1);
2454   defsubr (&Sprin1_to_string);
2455   defsubr (&Serror_message_string);
2456   defsubr (&Sprinc);
2457   defsubr (&Sprint);
2458   defsubr (&Sterpri);
2459   defsubr (&Swrite_char);
2460   defsubr (&Sexternal_debugging_output);
2461 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2462   defsubr (&Sredirect_debugging_output);
2463 #endif
2464 
2465   Qexternal_debugging_output = intern_c_string ("external-debugging-output");
2466   staticpro (&Qexternal_debugging_output);
2467 
2468   Qprint_escape_newlines = intern_c_string ("print-escape-newlines");
2469   staticpro (&Qprint_escape_newlines);
2470 
2471   Qprint_escape_multibyte = intern_c_string ("print-escape-multibyte");
2472   staticpro (&Qprint_escape_multibyte);
2473 
2474   Qprint_escape_nonascii = intern_c_string ("print-escape-nonascii");
2475   staticpro (&Qprint_escape_nonascii);
2476 
2477   print_prune_charset_plist = Qnil;
2478   staticpro (&print_prune_charset_plist);
2479 
2480   defsubr (&Swith_output_to_temp_buffer);
2481 }
2482 
2483 /* arch-tag: bc797170-94ae-41de-86e3-75e20f8f7a39
2484    (do not change this comment) */