src/print.c

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