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 in many cases,
 298    because printing one char can relocate.  */
 299
 300 print_string (string, printcharfun)
 301      Lisp_Object string;
 302      Lisp_Object printcharfun;
 303 {
 304   if (EQ (printcharfun, Qt))
 305     /* strout is safe for output to a frame (echo area).  */
 306     strout (XSTRING (string)->data, XSTRING (string)->size, printcharfun);
 307   else if (EQ (printcharfun, Qnil))
 308     {
 309 #ifdef MAX_PRINT_CHARS
 310       if (max_print)
 311         print_chars += XSTRING (string)->size;
 312 #endif /* MAX_PRINT_CHARS */
 313       insert_from_string (string, 0, XSTRING (string)->size, 1);
 314     }
 315   else
 316     {
 317       /* Otherwise, fetch the string address for each character.  */
 318       int i;
 319       int size = XSTRING (string)->size;
 320       struct gcpro gcpro1;
 321       GCPRO1 (string);
 322       for (i = 0; i < size; i++)
 323         PRINTCHAR (XSTRING (string)->data[i]);
 324       UNGCPRO;
 325     }
 326 }
 327 \f
 328 DEFUN ("write-char", Fwrite_char, Swrite_char, 1, 2, 0,
 329   "Output character CHAR to stream PRINTCHARFUN.\n\
 330 PRINTCHARFUN defaults to the value of `standard-output' (which see).")
 331   (ch, printcharfun)
 332      Lisp_Object ch, printcharfun;
 333 {
 334   struct buffer *old = current_buffer;
 335   int old_point = -1;
 336   int start_point;
 337   Lisp_Object original;
 338
 339   if (NILP (printcharfun))
 340     printcharfun = Vstandard_output;
 341   CHECK_NUMBER (ch, 0);
 342   PRINTPREPARE;
 343   PRINTCHAR (XINT (ch));
 344   PRINTFINISH;
 345   return ch;
 346 }
 347
 348 /* Used from outside of print.c to print a block of SIZE chars at DATA
 349    on the default output stream.
 350    Do not use this on the contents of a Lisp string.  */
 351
 352 write_string (data, size)
 353      char *data;
 354      int size;
 355 {
 356   struct buffer *old = current_buffer;
 357   Lisp_Object printcharfun;
 358   int old_point = -1;
 359   int start_point;
 360   Lisp_Object original;
 361
 362   printcharfun = Vstandard_output;
 363
 364   PRINTPREPARE;
 365   strout (data, size, printcharfun);
 366   PRINTFINISH;
 367 }
 368
 369 /* Used from outside of print.c to print a block of SIZE chars at DATA
 370    on a specified stream PRINTCHARFUN.
 371    Do not use this on the contents of a Lisp string.  */
 372
 373 write_string_1 (data, size, printcharfun)
 374      char *data;
 375      int size;
 376      Lisp_Object printcharfun;
 377 {
 378   struct buffer *old = current_buffer;
 379   int old_point = -1;
 380   int start_point;
 381   Lisp_Object original;
 382
 383   PRINTPREPARE;
 384   strout (data, size, printcharfun);
 385   PRINTFINISH;
 386 }
 387
 388
 389 #ifndef standalone
 390
 391 void
 392 temp_output_buffer_setup (bufname)
 393     char *bufname;
 394 {
 395   register struct buffer *old = current_buffer;
 396   register Lisp_Object buf;
 397
 398   Fset_buffer (Fget_buffer_create (build_string (bufname)));
 399
 400   current_buffer->directory = old->directory;
 401   current_buffer->read_only = Qnil;
 402   Ferase_buffer ();
 403
 404   XSETBUFFER (buf, current_buffer);
 405   specbind (Qstandard_output, buf);
 406
 407   set_buffer_internal (old);
 408 }
 409
 410 Lisp_Object
 411 internal_with_output_to_temp_buffer (bufname, function, args)
 412      char *bufname;
 413      Lisp_Object (*function) ();
 414      Lisp_Object args;
 415 {
 416   int count = specpdl_ptr - specpdl;
 417   Lisp_Object buf, val;
 418   struct gcpro gcpro1;
 419
 420   GCPRO1 (args);
 421   record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
 422   temp_output_buffer_setup (bufname);
 423   buf = Vstandard_output;
 424   UNGCPRO;
 425
 426   val = (*function) (args);
 427
 428   GCPRO1 (val);
 429   temp_output_buffer_show (buf);
 430   UNGCPRO;
 431
 432   return unbind_to (count, val);
 433 }
 434
 435 DEFUN ("with-output-to-temp-buffer", Fwith_output_to_temp_buffer, Swith_output_to_temp_buffer,
 436        1, UNEVALLED, 0,
 437   "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.\n\
 438 The buffer is cleared out initially, and marked as unmodified when done.\n\
 439 All output done by BODY is inserted in that buffer by default.\n\
 440 The buffer is displayed in another window, but not selected.\n\
 441 The value of the last form in BODY is returned.\n\
 442 If BODY does not finish normally, the buffer BUFNAME is not displayed.\n\n\
 443 If variable `temp-buffer-show-function' is non-nil, call it at the end\n\
 444 to get the buffer displayed.  It gets one argument, the buffer to display.")
 445   (args)
 446      Lisp_Object args;
 447 {
 448   struct gcpro gcpro1;
 449   Lisp_Object name;
 450   int count = specpdl_ptr - specpdl;
 451   Lisp_Object buf, val;
 452
 453   GCPRO1(args);
 454   name = Feval (Fcar (args));
 455   UNGCPRO;
 456
 457   CHECK_STRING (name, 0);
 458   temp_output_buffer_setup (XSTRING (name)->data);
 459   buf = Vstandard_output;
 460
 461   val = Fprogn (Fcdr (args));
 462
 463   temp_output_buffer_show (buf);
 464
 465   return unbind_to (count, val);
 466 }
 467 #endif /* not standalone */
 468 \f
 469 static void print ();
 470
 471 DEFUN ("terpri", Fterpri, Sterpri, 0, 1, 0,
 472   "Output a newline to stream PRINTCHARFUN.\n\
 473 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used.")
 474   (printcharfun)
 475      Lisp_Object printcharfun;
 476 {
 477   struct buffer *old = current_buffer;
 478   int old_point = -1;
 479   int start_point;
 480   Lisp_Object original;
 481
 482   if (NILP (printcharfun))
 483     printcharfun = Vstandard_output;
 484   PRINTPREPARE;
 485   PRINTCHAR ('\n');
 486   PRINTFINISH;
 487   return Qt;
 488 }
 489
 490 DEFUN ("prin1", Fprin1, Sprin1, 1, 2, 0,
 491   "Output the printed representation of OBJECT, any Lisp object.\n\
 492 Quoting characters are printed when needed to make output that `read'\n\
 493 can handle, whenever this is possible.\n\
 494 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
 495   (obj, printcharfun)
 496      Lisp_Object obj, printcharfun;
 497 {
 498   struct buffer *old = current_buffer;
 499   int old_point = -1;
 500   int start_point;
 501   Lisp_Object original;
 502
 503 #ifdef MAX_PRINT_CHARS
 504   max_print = 0;
 505 #endif /* MAX_PRINT_CHARS */
 506   if (NILP (printcharfun))
 507     printcharfun = Vstandard_output;
 508   PRINTPREPARE;
 509   print_depth = 0;
 510   print (obj, printcharfun, 1);
 511   PRINTFINISH;
 512   return obj;
 513 }
 514
 515 /* a buffer which is used to hold output being built by prin1-to-string */
 516 Lisp_Object Vprin1_to_string_buffer;
 517
 518 DEFUN ("prin1-to-string", Fprin1_to_string, Sprin1_to_string, 1, 2, 0,
 519   "Return a string containing the printed representation of OBJECT,\n\
 520 any Lisp object.  Quoting characters are used when needed to make output\n\
 521 that `read' can handle, whenever this is possible, unless the optional\n\
 522 second argument NOESCAPE is non-nil.")
 523   (obj, noescape)
 524      Lisp_Object obj, noescape;
 525 {
 526   struct buffer *old = current_buffer;
 527   int old_point = -1;
 528   int start_point;
 529   Lisp_Object original, printcharfun;
 530   struct gcpro gcpro1;
 531
 532   printcharfun = Vprin1_to_string_buffer;
 533   PRINTPREPARE;
 534   print_depth = 0;
 535   print (obj, printcharfun, NILP (noescape));
 536   /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
 537   PRINTFINISH;
 538   set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
 539   obj = Fbuffer_string ();
 540
 541   GCPRO1 (obj);
 542   Ferase_buffer ();
 543   set_buffer_internal (old);
 544   UNGCPRO;
 545
 546   return obj;
 547 }
 548
 549 DEFUN ("princ", Fprinc, Sprinc, 1, 2, 0,
 550   "Output the printed representation of OBJECT, any Lisp object.\n\
 551 No quoting characters are used; no delimiters are printed around\n\
 552 the contents of strings.\n\
 553 Output stream is PRINTCHARFUN, or value of standard-output (which see).")
 554   (obj, printcharfun)
 555      Lisp_Object obj, printcharfun;
 556 {
 557   struct buffer *old = current_buffer;
 558   int old_point = -1;
 559   int start_point;
 560   Lisp_Object original;
 561
 562   if (NILP (printcharfun))
 563     printcharfun = Vstandard_output;
 564   PRINTPREPARE;
 565   print_depth = 0;
 566   print (obj, printcharfun, 0);
 567   PRINTFINISH;
 568   return obj;
 569 }
 570
 571 DEFUN ("print", Fprint, Sprint, 1, 2, 0,
 572   "Output the printed representation of OBJECT, with newlines around it.\n\
 573 Quoting characters are printed when needed to make output that `read'\n\
 574 can handle, whenever this is possible.\n\
 575 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
 576   (obj, printcharfun)
 577      Lisp_Object obj, printcharfun;
 578 {
 579   struct buffer *old = current_buffer;
 580   int old_point = -1;
 581   int start_point;
 582   Lisp_Object original;
 583   struct gcpro gcpro1;
 584
 585 #ifdef MAX_PRINT_CHARS
 586   print_chars = 0;
 587   max_print = MAX_PRINT_CHARS;
 588 #endif /* MAX_PRINT_CHARS */
 589   if (NILP (printcharfun))
 590     printcharfun = Vstandard_output;
 591   GCPRO1 (obj);
 592   PRINTPREPARE;
 593   print_depth = 0;
 594   PRINTCHAR ('\n');
 595   print (obj, printcharfun, 1);
 596   PRINTCHAR ('\n');
 597   PRINTFINISH;
 598 #ifdef MAX_PRINT_CHARS
 599   max_print = 0;
 600   print_chars = 0;
 601 #endif /* MAX_PRINT_CHARS */
 602   UNGCPRO;
 603   return obj;
 604 }
 605
 606 /* The subroutine object for external-debugging-output is kept here
 607    for the convenience of the debugger.  */
 608 Lisp_Object Qexternal_debugging_output;
 609
 610 DEFUN ("external-debugging-output", Fexternal_debugging_output, Sexternal_debugging_output, 1, 1, 0,
 611   "Write CHARACTER to stderr.\n\
 612 You can call print while debugging emacs, and pass it this function\n\
 613 to make it write to the debugging output.\n")
 614   (character)
 615      Lisp_Object character;
 616 {
 617   CHECK_NUMBER (character, 0);
 618   putc (XINT (character), stderr);
 619
 620   return character;
 621 }
 622
 623 /* This is the interface for debugging printing.  */
 624
 625 void
 626 debug_print (arg)
 627      Lisp_Object arg;
 628 {
 629   Fprin1 (arg, Qexternal_debugging_output);
 630   fprintf (stderr, "\r\n");
 631 }
 632 \f
 633 #ifdef LISP_FLOAT_TYPE
 634
 635 /*
 636  * The buffer should be at least as large as the max string size of the
 637  * largest float, printed in the biggest notation.  This is undoubtably
 638  * 20d float_output_format, with the negative of the C-constant "HUGE"
 639  * from <math.h>.
 640  *
 641  * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
 642  *
 643  * I assume that IEEE-754 format numbers can take 329 bytes for the worst
 644  * case of -1e307 in 20d float_output_format. What is one to do (short of
 645  * re-writing _doprnt to be more sane)?
 646  *                      -wsr
 647  */
 648
 649 void
 650 float_to_string (buf, data)
 651      unsigned char *buf;
 652      double data;
 653 {
 654   unsigned char *cp;
 655   int width;
 656
 657   if (NILP (Vfloat_output_format)
 658       || !STRINGP (Vfloat_output_format))
 659   lose:
 660     {
 661       sprintf (buf, "%.17g", data);
 662       width = -1;
 663     }
 664   else                  /* oink oink */
 665     {
 666       /* Check that the spec we have is fully valid.
 667          This means not only valid for printf,
 668          but meant for floats, and reasonable.  */
 669       cp = XSTRING (Vfloat_output_format)->data;
 670
 671       if (cp[0] != '%')
 672         goto lose;
 673       if (cp[1] != '.')
 674         goto lose;
 675
 676       cp += 2;
 677
 678       /* Check the width specification.  */
 679       width = -1;
 680       if ('0' <= *cp && *cp <= '9')
 681         {
 682           width = 0;
 683           do
 684             width = (width * 10) + (*cp++ - '0');
 685           while (*cp >= '0' && *cp <= '9');
 686
 687           /* A precision of zero is valid only for %f.  */
 688           if (width > DBL_DIG
 689               || (width == 0 && *cp != 'f'))
 690             goto lose;
 691         }
 692
 693       if (*cp != 'e' && *cp != 'f' && *cp != 'g')
 694         goto lose;
 695
 696       if (cp[1] != 0)
 697         goto lose;
 698
 699       sprintf (buf, XSTRING (Vfloat_output_format)->data, data);
 700     }
 701
 702   /* Make sure there is a decimal point with digit after, or an
 703      exponent, so that the value is readable as a float.  But don't do
 704      this with "%.0f"; it's valid for that not to produce a decimal
 705      point.  Note that width can be 0 only for %.0f.  */
 706   if (width != 0)
 707     {
 708       for (cp = buf; *cp; cp++)
 709         if ((*cp < '0' || *cp > '9') && *cp != '-')
 710           break;
 711
 712       if (*cp == '.' && cp[1] == 0)
 713         {
 714           cp[1] = '0';
 715           cp[2] = 0;
 716         }
 717
 718       if (*cp == 0)
 719         {
 720           *cp++ = '.';
 721           *cp++ = '0';
 722           *cp++ = 0;
 723         }
 724     }
 725 }
 726 #endif /* LISP_FLOAT_TYPE */
 727 \f
 728 static void
 729 print (obj, printcharfun, escapeflag)
 730      Lisp_Object obj;
 731      register Lisp_Object printcharfun;
 732      int escapeflag;
 733 {
 734   char buf[30];
 735
 736   QUIT;
 737
 738 #if 1  /* I'm not sure this is really worth doing.  */
 739   /* Detect circularities and truncate them.
 740      No need to offer any alternative--this is better than an error.  */
 741   if (CONSP (obj) || VECTORP (obj) || COMPILEDP (obj))
 742     {
 743       int i;
 744       for (i = 0; i < print_depth; i++)
 745         if (EQ (obj, being_printed[i]))
 746           {
 747             sprintf (buf, "#%d", i);
 748             strout (buf, -1, printcharfun);
 749             return;
 750           }
 751     }
 752 #endif
 753
 754   being_printed[print_depth] = obj;
 755   print_depth++;
 756
 757   if (print_depth > PRINT_CIRCLE)
 758     error ("Apparently circular structure being printed");
 759 #ifdef MAX_PRINT_CHARS
 760   if (max_print && print_chars > max_print)
 761     {
 762       PRINTCHAR ('\n');
 763       print_chars = 0;
 764     }
 765 #endif /* MAX_PRINT_CHARS */
 766
 767   switch (XGCTYPE (obj))
 768     {
 769     case Lisp_Int:
 770       if (sizeof (int) == sizeof (EMACS_INT))
 771         sprintf (buf, "%d", XINT (obj));
 772       else if (sizeof (long) == sizeof (EMACS_INT))
 773         sprintf (buf, "%ld", XINT (obj));
 774       else
 775         abort ();
 776       strout (buf, -1, printcharfun);
 777       break;
 778
 779 #ifdef LISP_FLOAT_TYPE
 780     case Lisp_Float:
 781       {
 782         char pigbuf[350];       /* see comments in float_to_string */
 783
 784         float_to_string (pigbuf, XFLOAT(obj)->data);
 785         strout (pigbuf, -1, printcharfun);
 786       }
 787       break;
 788 #endif
 789
 790     case Lisp_String:
 791       if (!escapeflag)
 792         print_string (obj, printcharfun);
 793       else
 794         {
 795           register int i;
 796           register unsigned char c;
 797           struct gcpro gcpro1;
 798
 799           GCPRO1 (obj);
 800
 801 #ifdef USE_TEXT_PROPERTIES
 802           if (!NULL_INTERVAL_P (XSTRING (obj)->intervals))
 803             {
 804               PRINTCHAR ('#');
 805               PRINTCHAR ('(');
 806             }
 807 #endif
 808
 809           PRINTCHAR ('\"');
 810           for (i = 0; i < XSTRING (obj)->size; i++)
 811             {
 812               QUIT;
 813               c = XSTRING (obj)->data[i];
 814               if (c == '\n' && print_escape_newlines)
 815                 {
 816                   PRINTCHAR ('\\');
 817                   PRINTCHAR ('n');
 818                 }
 819               else if (c == '\f' && print_escape_newlines)
 820                 {
 821                   PRINTCHAR ('\\');
 822                   PRINTCHAR ('f');
 823                 }
 824               else
 825                 {
 826                   if (c == '\"' || c == '\\')
 827                     PRINTCHAR ('\\');
 828                   PRINTCHAR (c);
 829                 }
 830             }
 831           PRINTCHAR ('\"');
 832
 833 #ifdef USE_TEXT_PROPERTIES
 834           if (!NULL_INTERVAL_P (XSTRING (obj)->intervals))
 835             {
 836               traverse_intervals (XSTRING (obj)->intervals,
 837                                   0, 0, print_interval, printcharfun);
 838               PRINTCHAR (')');
 839             }
 840 #endif
 841
 842           UNGCPRO;
 843         }
 844       break;
 845
 846     case Lisp_Symbol:
 847       {
 848         register int confusing;
 849         register unsigned char *p = XSYMBOL (obj)->name->data;
 850         register unsigned char *end = p + XSYMBOL (obj)->name->size;
 851         register unsigned char c;
 852
 853         if (p != end && (*p == '-' || *p == '+')) p++;
 854         if (p == end)
 855           confusing = 0;
 856         else
 857           {
 858             while (p != end && *p >= '0' && *p <= '9')
 859               p++;
 860             confusing = (end == p);
 861           }
 862
 863         p = XSYMBOL (obj)->name->data;
 864         while (p != end)
 865           {
 866             QUIT;
 867             c = *p++;
 868             if (escapeflag)
 869               {
 870                 if (c == '\"' || c == '\\' || c == '\'' || c == ';' || c == '#' ||
 871                     c == '(' || c == ')' || c == ',' || c =='.' || c == '`' ||
 872                     c == '[' || c == ']' || c == '?' || c <= 040 || confusing)
 873                   PRINTCHAR ('\\'), confusing = 0;
 874               }
 875             PRINTCHAR (c);
 876           }
 877       }
 878       break;
 879
 880     case Lisp_Cons:
 881       /* If deeper than spec'd depth, print placeholder.  */
 882       if (INTEGERP (Vprint_level)
 883           && print_depth > XINT (Vprint_level))
 884         strout ("...", -1, printcharfun);
 885       else
 886         {
 887           PRINTCHAR ('(');
 888           {
 889             register int i = 0;
 890             register int max = 0;
 891
 892             if (INTEGERP (Vprint_length))
 893               max = XINT (Vprint_length);
 894             /* Could recognize circularities in cdrs here,
 895                but that would make printing of long lists quadratic.
 896                It's not worth doing.  */
 897             while (CONSP (obj))
 898               {
 899                 if (i++)
 900                   PRINTCHAR (' ');
 901                 if (max && i > max)
 902                   {
 903                     strout ("...", 3, printcharfun);
 904                     break;
 905                   }
 906                 print (Fcar (obj), printcharfun, escapeflag);
 907                 obj = Fcdr (obj);
 908               }
 909           }
 910           if (!NILP (obj) && !CONSP (obj))
 911             {
 912               strout (" . ", 3, printcharfun);
 913               print (obj, printcharfun, escapeflag);
 914             }
 915           PRINTCHAR (')');
 916         }
 917       break;
 918
 919     case Lisp_Vectorlike:
 920       if (PROCESSP (obj))
 921         {
 922           if (escapeflag)
 923             {
 924               strout ("#<process ", -1, printcharfun);
 925               print_string (XPROCESS (obj)->name, printcharfun);
 926               PRINTCHAR ('>');
 927             }
 928           else
 929             print_string (XPROCESS (obj)->name, printcharfun);
 930         }
 931       else if (BOOL_VECTOR_P (obj))
 932         {
 933           register int i;
 934           register unsigned char c;
 935           struct gcpro gcpro1;
 936           int size_in_chars
 937             = (XBOOL_VECTOR (obj)->size + BITS_PER_CHAR) / BITS_PER_CHAR;
 938
 939           GCPRO1 (obj);
 940
 941           PRINTCHAR ('#');
 942           PRINTCHAR ('&');
 943           sprintf (buf, "%d", XBOOL_VECTOR (obj)->size);
 944           strout (buf, -1, printcharfun);
 945           PRINTCHAR ('\"');
 946           for (i = 0; i < size_in_chars; i++)
 947             {
 948               QUIT;
 949               c = XBOOL_VECTOR (obj)->data[i];
 950               if (c == '\n' && print_escape_newlines)
 951                 {
 952                   PRINTCHAR ('\\');
 953                   PRINTCHAR ('n');
 954                 }
 955               else if (c == '\f' && print_escape_newlines)
 956                 {
 957                   PRINTCHAR ('\\');
 958                   PRINTCHAR ('f');
 959                 }
 960               else
 961                 {
 962                   if (c == '\"' || c == '\\')
 963                     PRINTCHAR ('\\');
 964                   PRINTCHAR (c);
 965                 }
 966             }
 967           PRINTCHAR ('\"');
 968
 969           UNGCPRO;
 970         }
 971       else if (SUBRP (obj))
 972         {
 973           strout ("#<subr ", -1, printcharfun);
 974           strout (XSUBR (obj)->symbol_name, -1, printcharfun);
 975           PRINTCHAR ('>');
 976         }
 977 #ifndef standalone
 978       else if (WINDOWP (obj))
 979         {
 980           strout ("#<window ", -1, printcharfun);
 981           sprintf (buf, "%d", XFASTINT (XWINDOW (obj)->sequence_number));
 982           strout (buf, -1, printcharfun);
 983           if (!NILP (XWINDOW (obj)->buffer))
 984             {
 985               strout (" on ", -1, printcharfun);
 986               print_string (XBUFFER (XWINDOW (obj)->buffer)->name, printcharfun);
 987             }
 988           PRINTCHAR ('>');
 989         }
 990       else if (BUFFERP (obj))
 991         {
 992           if (NILP (XBUFFER (obj)->name))
 993             strout ("#<killed buffer>", -1, printcharfun);
 994           else if (escapeflag)
 995             {
 996               strout ("#<buffer ", -1, printcharfun);
 997               print_string (XBUFFER (obj)->name, printcharfun);
 998               PRINTCHAR ('>');
 999             }
1000           else
1001             print_string (XBUFFER (obj)->name, printcharfun);
1002         }
1003       else if (WINDOW_CONFIGURATIONP (obj))
1004         {
1005           strout ("#<window-configuration>", -1, printcharfun);
1006         }
1007 #ifdef MULTI_FRAME
1008       else if (FRAMEP (obj))
1009         {
1010           strout ((FRAME_LIVE_P (XFRAME (obj))
1011                    ? "#<frame " : "#<dead frame "),
1012                   -1, printcharfun);
1013           print_string (XFRAME (obj)->name, printcharfun);
1014           sprintf (buf, " 0x%lx", (unsigned long) (XFRAME (obj)));
1015           strout (buf, -1, printcharfun);
1016           PRINTCHAR ('>');
1017         }
1018 #endif
1019 #endif /* not standalone */
1020       else
1021         {
1022           int size = XVECTOR (obj)->size;
1023           if (COMPILEDP (obj))
1024             {
1025               PRINTCHAR ('#');
1026               size &= PSEUDOVECTOR_SIZE_MASK;
1027             }
1028           if (CHAR_TABLE_P (obj))
1029             {
1030               /* We print a char-table as if it were a vector,
1031                  lumping the parent and default slots in with the
1032                  character slots.  But we add #^ as a prefix.  */
1033               PRINTCHAR ('#');
1034               PRINTCHAR ('^');
1035               size &= PSEUDOVECTOR_SIZE_MASK;
1036             }
1037           if (size & PSEUDOVECTOR_FLAG)
1038             goto badtype;
1039
1040           PRINTCHAR ('[');
1041           {
1042             register int i;
1043             register Lisp_Object tem;
1044             for (i = 0; i < size; i++)
1045               {
1046                 if (i) PRINTCHAR (' ');
1047                 tem = XVECTOR (obj)->contents[i];
1048                 print (tem, printcharfun, escapeflag);
1049               }
1050           }
1051           PRINTCHAR (']');
1052         }
1053       break;
1054
1055 #ifndef standalone
1056     case Lisp_Misc:
1057       switch (XMISCTYPE (obj))
1058         {
1059         case Lisp_Misc_Marker:
1060           strout ("#<marker ", -1, printcharfun);
1061           if (!(XMARKER (obj)->buffer))
1062             strout ("in no buffer", -1, printcharfun);
1063           else
1064             {
1065               sprintf (buf, "at %d", marker_position (obj));
1066               strout (buf, -1, printcharfun);
1067               strout (" in ", -1, printcharfun);
1068               print_string (XMARKER (obj)->buffer->name, printcharfun);
1069             }
1070           PRINTCHAR ('>');
1071           break;
1072
1073         case Lisp_Misc_Overlay:
1074           strout ("#<overlay ", -1, printcharfun);
1075           if (!(XMARKER (OVERLAY_START (obj))->buffer))
1076             strout ("in no buffer", -1, printcharfun);
1077           else
1078             {
1079               sprintf (buf, "from %d to %d in ",
1080                        marker_position (OVERLAY_START (obj)),
1081                        marker_position (OVERLAY_END   (obj)));
1082               strout (buf, -1, printcharfun);
1083               print_string (XMARKER (OVERLAY_START (obj))->buffer->name,
1084                             printcharfun);
1085             }
1086           PRINTCHAR ('>');
1087           break;
1088
1089       /* Remaining cases shouldn't happen in normal usage, but let's print
1090          them anyway for the benefit of the debugger.  */
1091         case Lisp_Misc_Free:
1092           strout ("#<misc free cell>", -1, printcharfun);
1093           break;
1094
1095         case Lisp_Misc_Intfwd:
1096           sprintf (buf, "#<intfwd to %d>", *XINTFWD (obj)->intvar);
1097           strout (buf, -1, printcharfun);
1098           break;
1099
1100         case Lisp_Misc_Boolfwd:
1101           sprintf (buf, "#<boolfwd to %s>",
1102                    (*XBOOLFWD (obj)->boolvar ? "t" : "nil"));
1103           strout (buf, -1, printcharfun);
1104           break;
1105
1106         case Lisp_Misc_Objfwd:
1107           strout (buf, "#<objfwd to ", -1, printcharfun);
1108           print (*XOBJFWD (obj)->objvar, printcharfun, escapeflag);
1109           PRINTCHAR ('>');
1110           break;
1111
1112         case Lisp_Misc_Buffer_Objfwd:
1113           strout (buf, "#<buffer_objfwd to ", -1, printcharfun);
1114           print (*(Lisp_Object *)((char *)current_buffer
1115                                   + XBUFFER_OBJFWD (obj)->offset),
1116                  printcharfun, escapeflag);
1117           PRINTCHAR ('>');
1118           break;
1119
1120         case Lisp_Misc_Kboard_Objfwd:
1121           strout (buf, "#<kboard_objfwd to ", -1, printcharfun);
1122           print (*(Lisp_Object *)((char *) current_kboard
1123                                   + XKBOARD_OBJFWD (obj)->offset),
1124                  printcharfun, escapeflag);
1125           PRINTCHAR ('>');
1126           break;
1127
1128         case Lisp_Misc_Buffer_Local_Value:
1129           strout ("#<buffer_local_value ", -1, printcharfun);
1130           goto do_buffer_local;
1131         case Lisp_Misc_Some_Buffer_Local_Value:
1132           strout ("#<some_buffer_local_value ", -1, printcharfun);
1133         do_buffer_local:
1134           strout ("[realvalue] ", -1, printcharfun);
1135           print (XBUFFER_LOCAL_VALUE (obj)->car, printcharfun, escapeflag);
1136           strout ("[buffer] ", -1, printcharfun);
1137           print (XCONS (XBUFFER_LOCAL_VALUE (obj)->cdr)->car,
1138                  printcharfun, escapeflag);
1139           strout ("[alist-elt] ", -1, printcharfun);
1140           print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj)->cdr)->cdr)->car,
1141                  printcharfun, escapeflag);
1142           strout ("[default-value] ", -1, printcharfun);
1143           print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj)->cdr)->cdr)->cdr,
1144                  printcharfun, escapeflag);
1145           PRINTCHAR ('>');
1146           break;
1147
1148         default:
1149           goto badtype;
1150         }
1151       break;
1152 #endif /* standalone */
1153
1154     default:
1155     badtype:
1156       {
1157         /* We're in trouble if this happens!
1158            Probably should just abort () */
1159         strout ("#<EMACS BUG: INVALID DATATYPE ", -1, printcharfun);
1160         if (MISCP (obj))
1161           sprintf (buf, "(MISC 0x%04x)", (int) XMISCTYPE (obj));
1162         else if (VECTORLIKEP (obj))
1163           sprintf (buf, "(PVEC 0x%08x)", (int) XVECTOR (obj)->size);
1164         else
1165           sprintf (buf, "(0x%02x)", (int) XTYPE (obj));
1166         strout (buf, -1, printcharfun);
1167         strout (" Save your buffers immediately and please report this bug>",
1168                 -1, printcharfun);
1169       }
1170     }
1171
1172   print_depth--;
1173 }
1174 \f
1175 #ifdef USE_TEXT_PROPERTIES
1176
1177 /* Print a description of INTERVAL using PRINTCHARFUN.
1178    This is part of printing a string that has text properties.  */
1179
1180 void
1181 print_interval (interval, printcharfun)
1182      INTERVAL interval;
1183      Lisp_Object printcharfun;
1184 {
1185   PRINTCHAR (' ');
1186   print (make_number (interval->position), printcharfun, 1);
1187   PRINTCHAR (' ');
1188   print (make_number (interval->position + LENGTH (interval)),
1189          printcharfun, 1);
1190   PRINTCHAR (' ');
1191   print (interval->plist, printcharfun, 1);
1192 }
1193
1194 #endif /* USE_TEXT_PROPERTIES */
1195 \f
1196 void
1197 syms_of_print ()
1198 {
1199   staticpro (&Qprint_escape_newlines);
1200   Qprint_escape_newlines = intern ("print-escape-newlines");
1201
1202   DEFVAR_LISP ("standard-output", &Vstandard_output,
1203     "Output stream `print' uses by default for outputting a character.\n\
1204 This may be any function of one argument.\n\
1205 It may also be a buffer (output is inserted before point)\n\
1206 or a marker (output is inserted and the marker is advanced)\n\
1207 or the symbol t (output appears in the minibuffer line).");
1208   Vstandard_output = Qt;
1209   Qstandard_output = intern ("standard-output");
1210   staticpro (&Qstandard_output);
1211
1212 #ifdef LISP_FLOAT_TYPE
1213   DEFVAR_LISP ("float-output-format", &Vfloat_output_format,
1214     "The format descriptor string used to print floats.\n\
1215 This is a %-spec like those accepted by `printf' in C,\n\
1216 but with some restrictions.  It must start with the two characters `%.'.\n\
1217 After that comes an integer precision specification,\n\
1218 and then a letter which controls the format.\n\
1219 The letters allowed are `e', `f' and `g'.\n\
1220 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"\n\
1221 Use `f' for decimal point notation \"DIGITS.DIGITS\".\n\
1222 Use `g' to choose the shorter of those two formats for the number at hand.\n\
1223 The precision in any of these cases is the number of digits following\n\
1224 the decimal point.  With `f', a precision of 0 means to omit the\n\
1225 decimal point.  0 is not allowed with `e' or `g'.\n\n\
1226 A value of nil means to use `%.17g'.");
1227   Vfloat_output_format = Qnil;
1228   Qfloat_output_format = intern ("float-output-format");
1229   staticpro (&Qfloat_output_format);
1230 #endif /* LISP_FLOAT_TYPE */
1231
1232   DEFVAR_LISP ("print-length", &Vprint_length,
1233     "Maximum length of list to print before abbreviating.\n\
1234 A value of nil means no limit.");
1235   Vprint_length = Qnil;
1236
1237   DEFVAR_LISP ("print-level", &Vprint_level,
1238     "Maximum depth of list nesting to print before abbreviating.\n\
1239 A value of nil means no limit.");
1240   Vprint_level = Qnil;
1241
1242   DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines,
1243     "Non-nil means print newlines in strings as backslash-n.\n\
1244 Also print formfeeds as backslash-f.");
1245   print_escape_newlines = 0;
1246
1247   /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
1248   staticpro (&Vprin1_to_string_buffer);
1249
1250   defsubr (&Sprin1);
1251   defsubr (&Sprin1_to_string);
1252   defsubr (&Sprinc);
1253   defsubr (&Sprint);
1254   defsubr (&Sterpri);
1255   defsubr (&Swrite_char);
1256   defsubr (&Sexternal_debugging_output);
1257
1258   Qexternal_debugging_output = intern ("external-debugging-output");
1259   staticpro (&Qexternal_debugging_output);
1260
1261 #ifndef standalone
1262   defsubr (&Swith_output_to_temp_buffer);
1263 #endif /* not standalone */
1264 }