src/print.c

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