src/print.c

   1 /* Lisp object printing and output streams.
   2    Copyright (C) 1985, 1986, 1988, 1993, 1994 Free Software Foundation, Inc.
   3
   4 This file is part of GNU Emacs.
   5
   6 GNU Emacs is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 2, or (at your option)
   9 any later version.
  10
  11 GNU Emacs is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with GNU Emacs; see the file COPYING.  If not, write to
  18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19
  20
  21 #include <config.h>
  22 #include <stdio.h>
  23 #undef NULL
  24 #include "lisp.h"
  25
  26 #ifndef standalone
  27 #include "buffer.h"
  28 #include "frame.h"
  29 #include "window.h"
  30 #include "process.h"
  31 #include "dispextern.h"
  32 #include "termchar.h"
  33 #endif /* not standalone */
  34
  35 #ifdef USE_TEXT_PROPERTIES
  36 #include "intervals.h"
  37 #endif
  38
  39 Lisp_Object Vstandard_output, Qstandard_output;
  40
  41 #ifdef LISP_FLOAT_TYPE
  42 Lisp_Object Vfloat_output_format, Qfloat_output_format;
  43 #endif /* LISP_FLOAT_TYPE */
  44
  45 /* Avoid actual stack overflow in print.  */
  46 int print_depth;
  47
  48 /* Detect most circularities to print finite output.  */
  49 #define PRINT_CIRCLE 200
  50 Lisp_Object being_printed[PRINT_CIRCLE];
  51
  52 /* Maximum length of list to print in full; noninteger means
  53    effectively infinity */
  54
  55 Lisp_Object Vprint_length;
  56
  57 /* Maximum depth of list to print in full; noninteger means
  58    effectively infinity.  */
  59
  60 Lisp_Object Vprint_level;
  61
  62 /* Nonzero means print newlines in strings as \n.  */
  63
  64 int print_escape_newlines;
  65
  66 Lisp_Object Qprint_escape_newlines;
  67
  68 /* Nonzero means print newline to stdout before next minibuffer message.
  69    Defined in xdisp.c */
  70
  71 extern int noninteractive_need_newline;
  72
  73 #ifdef MAX_PRINT_CHARS
  74 static int print_chars;
  75 static int max_print;
  76 #endif /* MAX_PRINT_CHARS */
  77
  78 void print_interval ();
  79 \f
  80 #if 0
  81 /* Convert between chars and GLYPHs */
  82
  83 int
  84 glyphlen (glyphs)
  85      register GLYPH *glyphs;
  86 {
  87   register int i = 0;
  88
  89   while (glyphs[i])
  90     i++;
  91   return i;
  92 }
  93
  94 void
  95 str_to_glyph_cpy (str, glyphs)
  96      char *str;
  97      GLYPH *glyphs;
  98 {
  99   register GLYPH *gp = glyphs;
 100   register char *cp = str;
 101
 102   while (*cp)
 103     *gp++ = *cp++;
 104 }
 105
 106 void
 107 str_to_glyph_ncpy (str, glyphs, n)
 108      char *str;
 109      GLYPH *glyphs;
 110      register int n;
 111 {
 112   register GLYPH *gp = glyphs;
 113   register char *cp = str;
 114
 115   while (n-- > 0)
 116     *gp++ = *cp++;
 117 }
 118
 119 void
 120 glyph_to_str_cpy (glyphs, str)
 121      GLYPH *glyphs;
 122      char *str;
 123 {
 124   register GLYPH *gp = glyphs;
 125   register char *cp = str;
 126
 127   while (*gp)
 128     *str++ = *gp++ & 0377;
 129 }
 130 #endif
 131 \f
 132 /* Low level output routines for characters and strings */
 133
 134 /* Lisp functions to do output using a stream
 135  must have the stream in a variable called printcharfun
 136  and must start with PRINTPREPARE and end with PRINTFINISH.
 137  Use PRINTCHAR to output one character,
 138  or call strout to output a block of characters.
 139  Also, each one must have the declarations
 140    struct buffer *old = current_buffer;
 141    int old_point = -1, start_point;
 142    Lisp_Object original;
 143 */
 144
 145 #define PRINTPREPARE                                            \
 146    original = printcharfun;                                     \
 147    if (NILP (printcharfun)) printcharfun = Qt;                  \
 148    if (BUFFERP (printcharfun))                                  \
 149      { if (XBUFFER (printcharfun) != current_buffer)            \
 150          Fset_buffer (printcharfun);                            \
 151        printcharfun = Qnil;}                                    \
 152    if (MARKERP (printcharfun))                                  \
 153      { if (!(XMARKER (original)->buffer))                       \
 154          error ("Marker does not point anywhere");              \
 155        if (XMARKER (original)->buffer != current_buffer)        \
 156          set_buffer_internal (XMARKER (original)->buffer);      \
 157        old_point = point;                                       \
 158        SET_PT (marker_position (printcharfun));                 \
 159        start_point = point;                                     \
 160        printcharfun = Qnil;}
 161
 162 #define PRINTFINISH                                     \
 163    if (MARKERP (original))                              \
 164      Fset_marker (original, make_number (point), Qnil); \
 165    if (old_point >= 0)                                  \
 166      SET_PT (old_point + (old_point >= start_point      \
 167                           ? point - start_point : 0));  \
 168    if (old != current_buffer)                           \
 169      set_buffer_internal (old)
 170
 171 #define PRINTCHAR(ch) printchar (ch, printcharfun)
 172
 173 /* Index of first unused element of FRAME_MESSAGE_BUF(mini_frame). */
 174 static int printbufidx;
 175
 176 static void
 177 printchar (ch, fun)
 178      unsigned char ch;
 179      Lisp_Object fun;
 180 {
 181   Lisp_Object ch1;
 182
 183 #ifdef MAX_PRINT_CHARS
 184   if (max_print)
 185     print_chars++;
 186 #endif /* MAX_PRINT_CHARS */
 187 #ifndef standalone
 188   if (EQ (fun, Qnil))
 189     {
 190       QUIT;
 191       insert (&ch, 1);
 192       return;
 193     }
 194
 195   if (EQ (fun, Qt))
 196     {
 197       FRAME_PTR mini_frame
 198         = XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window)));
 199
 200       if (noninteractive)
 201         {
 202           putchar (ch);
 203           noninteractive_need_newline = 1;
 204           return;
 205         }
 206
 207       if (echo_area_glyphs != FRAME_MESSAGE_BUF (mini_frame)
 208           || !message_buf_print)
 209         {
 210           message_log_maybe_newline ();
 211           echo_area_glyphs = FRAME_MESSAGE_BUF (mini_frame);
 212           printbufidx = 0;
 213           echo_area_glyphs_length = 0;
 214           message_buf_print = 1;
 215         }
 216
 217       message_dolog (&ch, 1, 0);
 218       if (printbufidx < FRAME_WIDTH (mini_frame) - 1)
 219         FRAME_MESSAGE_BUF (mini_frame)[printbufidx++] = ch;
 220       FRAME_MESSAGE_BUF (mini_frame)[printbufidx] = 0;
 221       echo_area_glyphs_length = printbufidx;
 222
 223       return;
 224     }
 225 #endif /* not standalone */
 226
 227   XSETFASTINT (ch1, ch);
 228   call1 (fun, ch1);
 229 }
 230
 231 static void
 232 strout (ptr, size, printcharfun)
 233      char *ptr;
 234      int size;
 235      Lisp_Object printcharfun;
 236 {
 237   int i = 0;
 238
 239   if (EQ (printcharfun, Qnil))
 240     {
 241       insert (ptr, size >= 0 ? size : strlen (ptr));
 242 #ifdef MAX_PRINT_CHARS
 243       if (max_print)
 244         print_chars += size >= 0 ? size : strlen(ptr);
 245 #endif /* MAX_PRINT_CHARS */
 246       return;
 247     }
 248   if (EQ (printcharfun, Qt))
 249     {
 250       FRAME_PTR mini_frame
 251         = XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window)));
 252
 253       i = size >= 0 ? size : strlen (ptr);
 254 #ifdef MAX_PRINT_CHARS
 255       if (max_print)
 256         print_chars += i;
 257 #endif /* MAX_PRINT_CHARS */
 258
 259       if (noninteractive)
 260         {
 261           fwrite (ptr, 1, i, stdout);
 262           noninteractive_need_newline = 1;
 263           return;
 264         }
 265
 266       if (echo_area_glyphs != FRAME_MESSAGE_BUF (mini_frame)
 267           || !message_buf_print)
 268         {
 269           message_log_maybe_newline ();
 270           echo_area_glyphs = FRAME_MESSAGE_BUF (mini_frame);
 271           printbufidx = 0;
 272           echo_area_glyphs_length = 0;
 273           message_buf_print = 1;
 274         }
 275
 276       message_dolog (ptr, i, 0);
 277       if (i > FRAME_WIDTH (mini_frame) - printbufidx - 1)
 278         i = FRAME_WIDTH (mini_frame) - printbufidx - 1;
 279       bcopy (ptr, &FRAME_MESSAGE_BUF (mini_frame) [printbufidx], i);
 280       printbufidx += i;
 281       echo_area_glyphs_length = printbufidx;
 282       FRAME_MESSAGE_BUF (mini_frame) [printbufidx] = 0;
 283
 284       return;
 285     }
 286
 287   if (size >= 0)
 288     while (i < size)
 289       PRINTCHAR (ptr[i++]);
 290   else
 291     while (ptr[i])
 292       PRINTCHAR (ptr[i++]);
 293 }
 294
 295 /* Print the contents of a string STRING using PRINTCHARFUN.
 296    It isn't safe to use strout, because printing one char can relocate.  */
 297
 298 print_string (string, printcharfun)
 299      Lisp_Object string;
 300      Lisp_Object printcharfun;
 301 {
 302   if (EQ (printcharfun, Qnil) || EQ (printcharfun, Qt))
 303     /* In predictable cases, strout is safe: output to buffer or frame.  */
 304     strout (XSTRING (string)->data, XSTRING (string)->size, printcharfun);
 305   else
 306     {
 307       /* Otherwise, fetch the string address for each character.  */
 308       int i;
 309       int size = XSTRING (string)->size;
 310       struct gcpro gcpro1;
 311       GCPRO1 (string);
 312       for (i = 0; i < size; i++)
 313         PRINTCHAR (XSTRING (string)->data[i]);
 314       UNGCPRO;
 315     }
 316 }
 317 \f
 318 DEFUN ("write-char", Fwrite_char, Swrite_char, 1, 2, 0,
 319   "Output character CHAR to stream PRINTCHARFUN.\n\
 320 PRINTCHARFUN defaults to the value of `standard-output' (which see).")
 321   (ch, printcharfun)
 322      Lisp_Object ch, printcharfun;
 323 {
 324   struct buffer *old = current_buffer;
 325   int old_point = -1;
 326   int start_point;
 327   Lisp_Object original;
 328
 329   if (NILP (printcharfun))
 330     printcharfun = Vstandard_output;
 331   CHECK_NUMBER (ch, 0);
 332   PRINTPREPARE;
 333   PRINTCHAR (XINT (ch));
 334   PRINTFINISH;
 335   return ch;
 336 }
 337
 338 /* Used from outside of print.c to print a block of SIZE chars at DATA
 339    on the default output stream.
 340    Do not use this on the contents of a Lisp string.  */
 341
 342 write_string (data, size)
 343      char *data;
 344      int size;
 345 {
 346   struct buffer *old = current_buffer;
 347   Lisp_Object printcharfun;
 348   int old_point = -1;
 349   int start_point;
 350   Lisp_Object original;
 351
 352   printcharfun = Vstandard_output;
 353
 354   PRINTPREPARE;
 355   strout (data, size, printcharfun);
 356   PRINTFINISH;
 357 }
 358
 359 /* Used from outside of print.c to print a block of SIZE chars at DATA
 360    on a specified stream PRINTCHARFUN.
 361    Do not use this on the contents of a Lisp string.  */
 362
 363 write_string_1 (data, size, printcharfun)
 364      char *data;
 365      int size;
 366      Lisp_Object printcharfun;
 367 {
 368   struct buffer *old = current_buffer;
 369   int old_point = -1;
 370   int start_point;
 371   Lisp_Object original;
 372
 373   PRINTPREPARE;
 374   strout (data, size, printcharfun);
 375   PRINTFINISH;
 376 }
 377
 378
 379 #ifndef standalone
 380
 381 void
 382 temp_output_buffer_setup (bufname)
 383     char *bufname;
 384 {
 385   register struct buffer *old = current_buffer;
 386   register Lisp_Object buf;
 387
 388   Fset_buffer (Fget_buffer_create (build_string (bufname)));
 389
 390   current_buffer->read_only = Qnil;
 391   Ferase_buffer ();
 392
 393   XSETBUFFER (buf, current_buffer);
 394   specbind (Qstandard_output, buf);
 395
 396   set_buffer_internal (old);
 397 }
 398
 399 Lisp_Object
 400 internal_with_output_to_temp_buffer (bufname, function, args)
 401      char *bufname;
 402      Lisp_Object (*function) ();
 403      Lisp_Object args;
 404 {
 405   int count = specpdl_ptr - specpdl;
 406   Lisp_Object buf, val;
 407   struct gcpro gcpro1;
 408
 409   GCPRO1 (args);
 410   record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
 411   temp_output_buffer_setup (bufname);
 412   buf = Vstandard_output;
 413   UNGCPRO;
 414
 415   val = (*function) (args);
 416
 417   GCPRO1 (val);
 418   temp_output_buffer_show (buf);
 419   UNGCPRO;
 420
 421   return unbind_to (count, val);
 422 }
 423
 424 DEFUN ("with-output-to-temp-buffer", Fwith_output_to_temp_buffer, Swith_output_to_temp_buffer,
 425        1, UNEVALLED, 0,
 426   "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.\n\
 427 The buffer is cleared out initially, and marked as unmodified when done.\n\
 428 All output done by BODY is inserted in that buffer by default.\n\
 429 The buffer is displayed in another window, but not selected.\n\
 430 The value of the last form in BODY is returned.\n\
 431 If BODY does not finish normally, the buffer BUFNAME is not displayed.\n\n\
 432 If variable `temp-buffer-show-function' is non-nil, call it at the end\n\
 433 to get the buffer displayed.  It gets one argument, the buffer to display.")
 434   (args)
 435      Lisp_Object args;
 436 {
 437   struct gcpro gcpro1;
 438   Lisp_Object name;
 439   int count = specpdl_ptr - specpdl;
 440   Lisp_Object buf, val;
 441
 442   GCPRO1(args);
 443   name = Feval (Fcar (args));
 444   UNGCPRO;
 445
 446   CHECK_STRING (name, 0);
 447   temp_output_buffer_setup (XSTRING (name)->data);
 448   buf = Vstandard_output;
 449
 450   val = Fprogn (Fcdr (args));
 451
 452   temp_output_buffer_show (buf);
 453
 454   return unbind_to (count, val);
 455 }
 456 #endif /* not standalone */
 457 \f
 458 static void print ();
 459
 460 DEFUN ("terpri", Fterpri, Sterpri, 0, 1, 0,
 461   "Output a newline to stream PRINTCHARFUN.\n\
 462 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used.")
 463   (printcharfun)
 464      Lisp_Object printcharfun;
 465 {
 466   struct buffer *old = current_buffer;
 467   int old_point = -1;
 468   int start_point;
 469   Lisp_Object original;
 470
 471   if (NILP (printcharfun))
 472     printcharfun = Vstandard_output;
 473   PRINTPREPARE;
 474   PRINTCHAR ('\n');
 475   PRINTFINISH;
 476   return Qt;
 477 }
 478
 479 DEFUN ("prin1", Fprin1, Sprin1, 1, 2, 0,
 480   "Output the printed representation of OBJECT, any Lisp object.\n\
 481 Quoting characters are printed when needed to make output that `read'\n\
 482 can handle, whenever this is possible.\n\
 483 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
 484   (obj, printcharfun)
 485      Lisp_Object obj, printcharfun;
 486 {
 487   struct buffer *old = current_buffer;
 488   int old_point = -1;
 489   int start_point;
 490   Lisp_Object original;
 491
 492 #ifdef MAX_PRINT_CHARS
 493   max_print = 0;
 494 #endif /* MAX_PRINT_CHARS */
 495   if (NILP (printcharfun))
 496     printcharfun = Vstandard_output;
 497   PRINTPREPARE;
 498   print_depth = 0;
 499   print (obj, printcharfun, 1);
 500   PRINTFINISH;
 501   return obj;
 502 }
 503
 504 /* a buffer which is used to hold output being built by prin1-to-string */
 505 Lisp_Object Vprin1_to_string_buffer;
 506
 507 DEFUN ("prin1-to-string", Fprin1_to_string, Sprin1_to_string, 1, 2, 0,
 508   "Return a string containing the printed representation of OBJECT,\n\
 509 any Lisp object.  Quoting characters are used when needed to make output\n\
 510 that `read' can handle, whenever this is possible, unless the optional\n\
 511 second argument NOESCAPE is non-nil.")
 512   (obj, noescape)
 513      Lisp_Object obj, noescape;
 514 {
 515   struct buffer *old = current_buffer;
 516   int old_point = -1;
 517   int start_point;
 518   Lisp_Object original, printcharfun;
 519   struct gcpro gcpro1;
 520
 521   printcharfun = Vprin1_to_string_buffer;
 522   PRINTPREPARE;
 523   print_depth = 0;
 524   print (obj, printcharfun, NILP (noescape));
 525   /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
 526   PRINTFINISH;
 527   set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
 528   obj = Fbuffer_string ();
 529
 530   GCPRO1 (obj);
 531   Ferase_buffer ();
 532   set_buffer_internal (old);
 533   UNGCPRO;
 534
 535   return obj;
 536 }
 537
 538 DEFUN ("princ", Fprinc, Sprinc, 1, 2, 0,
 539   "Output the printed representation of OBJECT, any Lisp object.\n\
 540 No quoting characters are used; no delimiters are printed around\n\
 541 the contents of strings.\n\
 542 Output stream is PRINTCHARFUN, or value of standard-output (which see).")
 543   (obj, printcharfun)
 544      Lisp_Object obj, printcharfun;
 545 {
 546   struct buffer *old = current_buffer;
 547   int old_point = -1;
 548   int start_point;
 549   Lisp_Object original;
 550
 551   if (NILP (printcharfun))
 552     printcharfun = Vstandard_output;
 553   PRINTPREPARE;
 554   print_depth = 0;
 555   print (obj, printcharfun, 0);
 556   PRINTFINISH;
 557   return obj;
 558 }
 559
 560 DEFUN ("print", Fprint, Sprint, 1, 2, 0,
 561   "Output the printed representation of OBJECT, with newlines around it.\n\
 562 Quoting characters are printed when needed to make output that `read'\n\
 563 can handle, whenever this is possible.\n\
 564 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
 565   (obj, printcharfun)
 566      Lisp_Object obj, printcharfun;
 567 {
 568   struct buffer *old = current_buffer;
 569   int old_point = -1;
 570   int start_point;
 571   Lisp_Object original;
 572   struct gcpro gcpro1;
 573
 574 #ifdef MAX_PRINT_CHARS
 575   print_chars = 0;
 576   max_print = MAX_PRINT_CHARS;
 577 #endif /* MAX_PRINT_CHARS */
 578   if (NILP (printcharfun))
 579     printcharfun = Vstandard_output;
 580   GCPRO1 (obj);
 581   PRINTPREPARE;
 582   print_depth = 0;
 583   PRINTCHAR ('\n');
 584   print (obj, printcharfun, 1);
 585   PRINTCHAR ('\n');
 586   PRINTFINISH;
 587 #ifdef MAX_PRINT_CHARS
 588   max_print = 0;
 589   print_chars = 0;
 590 #endif /* MAX_PRINT_CHARS */
 591   UNGCPRO;
 592   return obj;
 593 }
 594
 595 /* The subroutine object for external-debugging-output is kept here
 596    for the convenience of the debugger.  */
 597 Lisp_Object Qexternal_debugging_output;
 598
 599 DEFUN ("external-debugging-output", Fexternal_debugging_output, Sexternal_debugging_output, 1, 1, 0,
 600   "Write CHARACTER to stderr.\n\
 601 You can call print while debugging emacs, and pass it this function\n\
 602 to make it write to the debugging output.\n")
 603   (character)
 604      Lisp_Object character;
 605 {
 606   CHECK_NUMBER (character, 0);
 607   putc (XINT (character), stderr);
 608
 609   return character;
 610 }
 611
 612 /* This is the interface for debugging printing.  */
 613
 614 void
 615 debug_print (arg)
 616      Lisp_Object arg;
 617 {
 618   Fprin1 (arg, Qexternal_debugging_output);
 619 }
 620 \f
 621 #ifdef LISP_FLOAT_TYPE
 622
 623 /*
 624  * The buffer should be at least as large as the max string size of the
 625  * largest float, printed in the biggest notation.  This is undoubtably
 626  * 20d float_output_format, with the negative of the C-constant "HUGE"
 627  * from <math.h>.
 628  *
 629  * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
 630  *
 631  * I assume that IEEE-754 format numbers can take 329 bytes for the worst
 632  * case of -1e307 in 20d float_output_format. What is one to do (short of
 633  * re-writing _doprnt to be more sane)?
 634  *                      -wsr
 635  */
 636
 637 void
 638 float_to_string (buf, data)
 639      unsigned char *buf;
 640      double data;
 641 {
 642   unsigned char *cp;
 643   int width;
 644
 645   if (NILP (Vfloat_output_format)
 646       || !STRINGP (Vfloat_output_format))
 647   lose:
 648     {
 649       sprintf (buf, "%.17g", data);
 650       width = -1;
 651     }
 652   else                  /* oink oink */
 653     {
 654       /* Check that the spec we have is fully valid.
 655          This means not only valid for printf,
 656          but meant for floats, and reasonable.  */
 657       cp = XSTRING (Vfloat_output_format)->data;
 658
 659       if (cp[0] != '%')
 660         goto lose;
 661       if (cp[1] != '.')
 662         goto lose;
 663
 664       cp += 2;
 665
 666       /* Check the width specification.  */
 667       width = -1;
 668       if ('0' <= *cp && *cp <= '9')
 669         for (width = 0; (*cp >= '0' && *cp <= '9'); cp++)
 670           width = (width * 10) + (*cp - '0');
 671
 672       if (*cp != 'e' && *cp != 'f' && *cp != 'g')
 673         goto lose;
 674
 675       /* A precision of zero is valid for %f; everything else requires
 676          at least one.  Width may be omitted anywhere.  */
 677       if (width != -1
 678           && (width < (*cp != 'f')
 679               || width > DBL_DIG))
 680         goto lose;
 681
 682       if (cp[1] != 0)
 683         goto lose;
 684
 685       sprintf (buf, XSTRING (Vfloat_output_format)->data, data);
 686     }
 687
 688   /* Make sure there is a decimal point with digit after, or an
 689      exponent, so that the value is readable as a float.  But don't do
 690      this with "%.0f"; it's valid for that not to produce a decimal
 691      point.  Note that width can be 0 only for %.0f.  */
 692   if (width != 0)
 693     {
 694       for (cp = buf; *cp; cp++)
 695         if ((*cp < '0' || *cp > '9') && *cp != '-')
 696           break;
 697
 698       if (*cp == '.' && cp[1] == 0)
 699         {
 700           cp[1] = '0';
 701           cp[2] = 0;
 702         }
 703
 704       if (*cp == 0)
 705         {
 706           *cp++ = '.';
 707           *cp++ = '0';
 708           *cp++ = 0;
 709         }
 710     }
 711 }
 712 #endif /* LISP_FLOAT_TYPE */
 713 \f
 714 static void
 715 print (obj, printcharfun, escapeflag)
 716      Lisp_Object obj;
 717      register Lisp_Object printcharfun;
 718      int escapeflag;
 719 {
 720   char buf[30];
 721
 722   QUIT;
 723
 724 #if 1  /* I'm not sure this is really worth doing.  */
 725   /* Detect circularities and truncate them.
 726      No need to offer any alternative--this is better than an error.  */
 727   if (CONSP (obj) || VECTORP (obj) || COMPILEDP (obj))
 728     {
 729       int i;
 730       for (i = 0; i < print_depth; i++)
 731         if (EQ (obj, being_printed[i]))
 732           {
 733             sprintf (buf, "#%d", i);
 734             strout (buf, -1, printcharfun);
 735             return;
 736           }
 737     }
 738 #endif
 739
 740   being_printed[print_depth] = obj;
 741   print_depth++;
 742
 743   if (print_depth > PRINT_CIRCLE)
 744     error ("Apparently circular structure being printed");
 745 #ifdef MAX_PRINT_CHARS
 746   if (max_print && print_chars > max_print)
 747     {
 748       PRINTCHAR ('\n');
 749       print_chars = 0;
 750     }
 751 #endif /* MAX_PRINT_CHARS */
 752
 753   switch (XGCTYPE (obj))
 754     {
 755     case Lisp_Int:
 756       sprintf (buf, "%d", XINT (obj));
 757       strout (buf, -1, printcharfun);
 758       break;
 759
 760 #ifdef LISP_FLOAT_TYPE
 761     case Lisp_Float:
 762       {
 763         char pigbuf[350];       /* see comments in float_to_string */
 764
 765         float_to_string (pigbuf, XFLOAT(obj)->data);
 766         strout (pigbuf, -1, printcharfun);
 767       }
 768       break;
 769 #endif
 770
 771     case Lisp_String:
 772       if (!escapeflag)
 773         print_string (obj, printcharfun);
 774       else
 775         {
 776           register int i;
 777           register unsigned char c;
 778           struct gcpro gcpro1;
 779
 780           GCPRO1 (obj);
 781
 782 #ifdef USE_TEXT_PROPERTIES
 783           if (!NULL_INTERVAL_P (XSTRING (obj)->intervals))
 784             {
 785               PRINTCHAR ('#');
 786               PRINTCHAR ('(');
 787             }
 788 #endif
 789
 790           PRINTCHAR ('\"');
 791           for (i = 0; i < XSTRING (obj)->size; i++)
 792             {
 793               QUIT;
 794               c = XSTRING (obj)->data[i];
 795               if (c == '\n' && print_escape_newlines)
 796                 {
 797                   PRINTCHAR ('\\');
 798                   PRINTCHAR ('n');
 799                 }
 800               else if (c == '\f' && print_escape_newlines)
 801                 {
 802                   PRINTCHAR ('\\');
 803                   PRINTCHAR ('f');
 804                 }
 805               else
 806                 {
 807                   if (c == '\"' || c == '\\')
 808                     PRINTCHAR ('\\');
 809                   PRINTCHAR (c);
 810                 }
 811             }
 812           PRINTCHAR ('\"');
 813
 814 #ifdef USE_TEXT_PROPERTIES
 815           if (!NULL_INTERVAL_P (XSTRING (obj)->intervals))
 816             {
 817               traverse_intervals (XSTRING (obj)->intervals,
 818                                   0, 0, print_interval, printcharfun);
 819               PRINTCHAR (')');
 820             }
 821 #endif
 822
 823           UNGCPRO;
 824         }
 825       break;
 826
 827     case Lisp_Symbol:
 828       {
 829         register int confusing;
 830         register unsigned char *p = XSYMBOL (obj)->name->data;
 831         register unsigned char *end = p + XSYMBOL (obj)->name->size;
 832         register unsigned char c;
 833
 834         if (p != end && (*p == '-' || *p == '+')) p++;
 835         if (p == end)
 836           confusing = 0;
 837         else
 838           {
 839             while (p != end && *p >= '0' && *p <= '9')
 840               p++;
 841             confusing = (end == p);
 842           }
 843
 844         p = XSYMBOL (obj)->name->data;
 845         while (p != end)
 846           {
 847             QUIT;
 848             c = *p++;
 849             if (escapeflag)
 850               {
 851                 if (c == '\"' || c == '\\' || c == '\'' || c == ';' || c == '#' ||
 852                     c == '(' || c == ')' || c == ',' || c =='.' || c == '`' ||
 853                     c == '[' || c == ']' || c == '?' || c <= 040 || confusing)
 854                   PRINTCHAR ('\\'), confusing = 0;
 855               }
 856             PRINTCHAR (c);
 857           }
 858       }
 859       break;
 860
 861     case Lisp_Cons:
 862       /* If deeper than spec'd depth, print placeholder.  */
 863       if (INTEGERP (Vprint_level)
 864           && print_depth > XINT (Vprint_level))
 865         strout ("...", -1, printcharfun);
 866       else
 867         {
 868           PRINTCHAR ('(');
 869           {
 870             register int i = 0;
 871             register int max = 0;
 872
 873             if (INTEGERP (Vprint_length))
 874               max = XINT (Vprint_length);
 875             /* Could recognize circularities in cdrs here,
 876                but that would make printing of long lists quadratic.
 877                It's not worth doing.  */
 878             while (CONSP (obj))
 879               {
 880                 if (i++)
 881                   PRINTCHAR (' ');
 882                 if (max && i > max)
 883                   {
 884                     strout ("...", 3, printcharfun);
 885                     break;
 886                   }
 887                 print (Fcar (obj), printcharfun, escapeflag);
 888                 obj = Fcdr (obj);
 889               }
 890           }
 891           if (!NILP (obj) && !CONSP (obj))
 892             {
 893               strout (" . ", 3, printcharfun);
 894               print (obj, printcharfun, escapeflag);
 895             }
 896           PRINTCHAR (')');
 897         }
 898       break;
 899
 900     case Lisp_Vectorlike:
 901       if (PROCESSP (obj))
 902         {
 903           if (escapeflag)
 904             {
 905               strout ("#<process ", -1, printcharfun);
 906               print_string (XPROCESS (obj)->name, printcharfun);
 907               PRINTCHAR ('>');
 908             }
 909           else
 910             print_string (XPROCESS (obj)->name, printcharfun);
 911         }
 912       else if (SUBRP (obj))
 913         {
 914           strout ("#<subr ", -1, printcharfun);
 915           strout (XSUBR (obj)->symbol_name, -1, printcharfun);
 916           PRINTCHAR ('>');
 917         }
 918 #ifndef standalone
 919       else if (WINDOWP (obj))
 920         {
 921           strout ("#<window ", -1, printcharfun);
 922           sprintf (buf, "%d", XFASTINT (XWINDOW (obj)->sequence_number));
 923           strout (buf, -1, printcharfun);
 924           if (!NILP (XWINDOW (obj)->buffer))
 925             {
 926               strout (" on ", -1, printcharfun);
 927               print_string (XBUFFER (XWINDOW (obj)->buffer)->name, printcharfun);
 928             }
 929           PRINTCHAR ('>');
 930         }
 931       else if (BUFFERP (obj))
 932         {
 933           if (NILP (XBUFFER (obj)->name))
 934             strout ("#<killed buffer>", -1, printcharfun);
 935           else if (escapeflag)
 936             {
 937               strout ("#<buffer ", -1, printcharfun);
 938               print_string (XBUFFER (obj)->name, printcharfun);
 939               PRINTCHAR ('>');
 940             }
 941           else
 942             print_string (XBUFFER (obj)->name, printcharfun);
 943         }
 944       else if (WINDOW_CONFIGURATIONP (obj))
 945         {
 946           strout ("#<window-configuration>", -1, printcharfun);
 947         }
 948 #ifdef MULTI_FRAME
 949       else if (FRAMEP (obj))
 950         {
 951           strout ((FRAME_LIVE_P (XFRAME (obj))
 952                    ? "#<frame " : "#<dead frame "),
 953                   -1, printcharfun);
 954           print_string (XFRAME (obj)->name, printcharfun);
 955           sprintf (buf, " 0x%lx", (unsigned long) (XFRAME (obj)));
 956           strout (buf, -1, printcharfun);
 957           PRINTCHAR ('>');
 958         }
 959 #endif
 960 #endif /* not standalone */
 961       else
 962         {
 963           int size = XVECTOR (obj)->size;
 964           if (COMPILEDP (obj))
 965             {
 966               PRINTCHAR ('#');
 967               size &= PSEUDOVECTOR_SIZE_MASK;
 968             }
 969           if (size & PSEUDOVECTOR_FLAG)
 970             goto badtype;
 971
 972           PRINTCHAR ('[');
 973           {
 974             register int i;
 975             register Lisp_Object tem;
 976             for (i = 0; i < size; i++)
 977               {
 978                 if (i) PRINTCHAR (' ');
 979                 tem = XVECTOR (obj)->contents[i];
 980                 print (tem, printcharfun, escapeflag);
 981               }
 982           }
 983           PRINTCHAR (']');
 984         }
 985       break;
 986
 987 #ifndef standalone
 988     case Lisp_Misc:
 989       switch (XMISC (obj)->type)
 990         {
 991         case Lisp_Misc_Marker:
 992           strout ("#<marker ", -1, printcharfun);
 993           if (!(XMARKER (obj)->buffer))
 994             strout ("in no buffer", -1, printcharfun);
 995           else
 996             {
 997               sprintf (buf, "at %d", marker_position (obj));
 998               strout (buf, -1, printcharfun);
 999               strout (" in ", -1, printcharfun);
1000               print_string (XMARKER (obj)->buffer->name, printcharfun);
1001             }
1002           PRINTCHAR ('>');
1003           break;
1004
1005         case Lisp_Misc_Overlay:
1006           strout ("#<overlay ", -1, printcharfun);
1007           if (!(XMARKER (OVERLAY_START (obj))->buffer))
1008             strout ("in no buffer", -1, printcharfun);
1009           else
1010             {
1011               sprintf (buf, "from %d to %d in ",
1012                        marker_position (OVERLAY_START (obj)),
1013                        marker_position (OVERLAY_END   (obj)));
1014               strout (buf, -1, printcharfun);
1015               print_string (XMARKER (OVERLAY_START (obj))->buffer->name,
1016                             printcharfun);
1017             }
1018           PRINTCHAR ('>');
1019           break;
1020
1021       /* Remaining cases shouldn't happen in normal usage, but let's print
1022          them anyway for the benefit of the debugger.  */
1023         case Lisp_Misc_Free:
1024           strout ("#<misc free cell>", -1, printcharfun);
1025           break;
1026
1027         case Lisp_Misc_Intfwd:
1028           sprintf (buf, "#<intfwd to %d>", *XINTFWD (obj)->intvar);
1029           strout (buf, -1, printcharfun);
1030           break;
1031
1032         case Lisp_Misc_Boolfwd:
1033           sprintf (buf, "#<boolfwd to %s>",
1034                    (*XBOOLFWD (obj)->boolvar ? "t" : "nil"));
1035           strout (buf, -1, printcharfun);
1036           break;
1037
1038         case Lisp_Misc_Objfwd:
1039           strout (buf, "#<objfwd to ", -1, printcharfun);
1040           print (*XOBJFWD (obj)->objvar, printcharfun, escapeflag);
1041           PRINTCHAR ('>');
1042           break;
1043
1044         case Lisp_Misc_Buffer_Objfwd:
1045           strout (buf, "#<buffer_objfwd to ", -1, printcharfun);
1046           print (*(Lisp_Object *)((char *)current_buffer
1047                                   + XBUFFER_OBJFWD (obj)->offset),
1048                  printcharfun, escapeflag);
1049           PRINTCHAR ('>');
1050           break;
1051
1052         case Lisp_Misc_Display_Objfwd:
1053           strout (buf, "#<display_objfwd to ", -1, printcharfun);
1054           if (!current_perdisplay)
1055             strout ("no-current-perdisplay");
1056           else
1057             print (*(Lisp_Object *)((char *) current_perdisplay
1058                                     + XDISPLAY_OBJFWD (obj)->offset),
1059                    printcharfun, escapeflag);
1060           PRINTCHAR ('>');
1061           break;
1062
1063         case Lisp_Misc_Buffer_Local_Value:
1064           strout ("#<buffer_local_value ", -1, printcharfun);
1065           goto do_buffer_local;
1066         case Lisp_Misc_Some_Buffer_Local_Value:
1067           strout ("#<some_buffer_local_value ", -1, printcharfun);
1068         do_buffer_local:
1069           strout ("[realvalue] ", -1, printcharfun);
1070           print (XBUFFER_LOCAL_VALUE (obj)->car, printcharfun, escapeflag);
1071           strout ("[buffer] ", -1, printcharfun);
1072           print (XCONS (XBUFFER_LOCAL_VALUE (obj)->cdr)->car,
1073                  printcharfun, escapeflag);
1074           strout ("[alist-elt] ", -1, printcharfun);
1075           print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj)->cdr)->cdr)->car,
1076                  printcharfun, escapeflag);
1077           strout ("[default-value] ", -1, printcharfun);
1078           print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj)->cdr)->cdr)->cdr,
1079                  printcharfun, escapeflag);
1080           PRINTCHAR ('>');
1081           break;
1082
1083         default:
1084           goto badtype;
1085         }
1086       break;
1087 #endif /* standalone */
1088
1089     default:
1090     badtype:
1091       {
1092         /* We're in trouble if this happens!
1093            Probably should just abort () */
1094         strout ("#<EMACS BUG: INVALID DATATYPE ", -1, printcharfun);
1095         if (MISCP (obj))
1096           sprintf (buf, "(MISC 0x%04x)", (int) XMISC (obj)->type);
1097         else if (VECTORLIKEP (obj))
1098           sprintf (buf, "(PVEC 0x%08x)", (int) XVECTOR (obj)->size);
1099         else
1100           sprintf (buf, "(0x%02x)", (int) XTYPE (obj));
1101         strout (buf, -1, printcharfun);
1102         strout (" Save your buffers immediately and please report this bug>",
1103                 -1, printcharfun);
1104       }
1105     }
1106
1107   print_depth--;
1108 }
1109 \f
1110 #ifdef USE_TEXT_PROPERTIES
1111
1112 /* Print a description of INTERVAL using PRINTCHARFUN.
1113    This is part of printing a string that has text properties.  */
1114
1115 void
1116 print_interval (interval, printcharfun)
1117      INTERVAL interval;
1118      Lisp_Object printcharfun;
1119 {
1120   PRINTCHAR (' ');
1121   print (make_number (interval->position), printcharfun, 1);
1122   PRINTCHAR (' ');
1123   print (make_number (interval->position + LENGTH (interval)),
1124          printcharfun, 1);
1125   PRINTCHAR (' ');
1126   print (interval->plist, printcharfun, 1);
1127 }
1128
1129 #endif /* USE_TEXT_PROPERTIES */
1130 \f
1131 void
1132 syms_of_print ()
1133 {
1134   staticpro (&Qprint_escape_newlines);
1135   Qprint_escape_newlines = intern ("print-escape-newlines");
1136
1137   DEFVAR_LISP ("standard-output", &Vstandard_output,
1138     "Output stream `print' uses by default for outputting a character.\n\
1139 This may be any function of one argument.\n\
1140 It may also be a buffer (output is inserted before point)\n\
1141 or a marker (output is inserted and the marker is advanced)\n\
1142 or the symbol t (output appears in the minibuffer line).");
1143   Vstandard_output = Qt;
1144   Qstandard_output = intern ("standard-output");
1145   staticpro (&Qstandard_output);
1146
1147 #ifdef LISP_FLOAT_TYPE
1148   DEFVAR_LISP ("float-output-format", &Vfloat_output_format,
1149     "The format descriptor string used to print floats.\n\
1150 This is a %-spec like those accepted by `printf' in C,\n\
1151 but with some restrictions.  It must start with the two characters `%.'.\n\
1152 After that comes an integer precision specification,\n\
1153 and then a letter which controls the format.\n\
1154 The letters allowed are `e', `f' and `g'.\n\
1155 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"\n\
1156 Use `f' for decimal point notation \"DIGITS.DIGITS\".\n\
1157 Use `g' to choose the shorter of those two formats for the number at hand.\n\
1158 The precision in any of these cases is the number of digits following\n\
1159 the decimal point.  With `f', a precision of 0 means to omit the\n\
1160 decimal point.  0 is not allowed with `e' or `g'.\n\n\
1161 A value of nil means to use `%.17g'.");
1162   Vfloat_output_format = Qnil;
1163   Qfloat_output_format = intern ("float-output-format");
1164   staticpro (&Qfloat_output_format);
1165 #endif /* LISP_FLOAT_TYPE */
1166
1167   DEFVAR_LISP ("print-length", &Vprint_length,
1168     "Maximum length of list to print before abbreviating.\n\
1169 A value of nil means no limit.");
1170   Vprint_length = Qnil;
1171
1172   DEFVAR_LISP ("print-level", &Vprint_level,
1173     "Maximum depth of list nesting to print before abbreviating.\n\
1174 A value of nil means no limit.");
1175   Vprint_level = Qnil;
1176
1177   DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines,
1178     "Non-nil means print newlines in strings as backslash-n.\n\
1179 Also print formfeeds as backslash-f.");
1180   print_escape_newlines = 0;
1181
1182   /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
1183   staticpro (&Vprin1_to_string_buffer);
1184
1185   defsubr (&Sprin1);
1186   defsubr (&Sprin1_to_string);
1187   defsubr (&Sprinc);
1188   defsubr (&Sprint);
1189   defsubr (&Sterpri);
1190   defsubr (&Swrite_char);
1191   defsubr (&Sexternal_debugging_output);
1192
1193   Qexternal_debugging_output = intern ("external-debugging-output");
1194   staticpro (&Qexternal_debugging_output);
1195
1196 #ifndef standalone
1197   defsubr (&Swith_output_to_temp_buffer);
1198 #endif /* not standalone */
1199 }