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