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, Inc., 59 Temple Place - Suite 330,
  19 Boston, MA 02111-1307, USA.  */
  20
  21
  22 #include <config.h>
  23 #include <stdio.h>
  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 CHARACTER to stream PRINTCHARFUN.\n\
 330 PRINTCHARFUN defaults to the value of `standard-output' (which see).")
 331   (character, printcharfun)
 332      Lisp_Object character, 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 (character, 0);
 342   PRINTPREPARE;
 343   PRINTCHAR (XINT (character));
 344   PRINTFINISH;
 345   return character;
 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   (object, printcharfun)
 496      Lisp_Object object, 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 (object, printcharfun, 1);
 511   PRINTFINISH;
 512   return object;
 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   (object, noescape)
 524      Lisp_Object object, 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, gcpro2;
 531   Lisp_Object tem;
 532
 533   /* Save and restore this--we are altering a buffer
 534      but we don't want to deactivate the mark just for that.
 535      No need for specbind, since errors deactivate the mark.  */
 536   tem = Vdeactivate_mark;
 537   GCPRO2 (object, tem);
 538
 539   printcharfun = Vprin1_to_string_buffer;
 540   PRINTPREPARE;
 541   print_depth = 0;
 542   print (object, printcharfun, NILP (noescape));
 543   /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
 544   PRINTFINISH;
 545   set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
 546   object = Fbuffer_string ();
 547
 548   Ferase_buffer ();
 549   set_buffer_internal (old);
 550
 551   Vdeactivate_mark = tem;
 552   UNGCPRO;
 553
 554   return object;
 555 }
 556
 557 DEFUN ("princ", Fprinc, Sprinc, 1, 2, 0,
 558   "Output the printed representation of OBJECT, any Lisp object.\n\
 559 No quoting characters are used; no delimiters are printed around\n\
 560 the contents of strings.\n\
 561 Output stream is PRINTCHARFUN, or value of standard-output (which see).")
 562   (object, printcharfun)
 563      Lisp_Object object, printcharfun;
 564 {
 565   struct buffer *old = current_buffer;
 566   int old_point = -1;
 567   int start_point;
 568   Lisp_Object original;
 569
 570   if (NILP (printcharfun))
 571     printcharfun = Vstandard_output;
 572   PRINTPREPARE;
 573   print_depth = 0;
 574   print (object, printcharfun, 0);
 575   PRINTFINISH;
 576   return object;
 577 }
 578
 579 DEFUN ("print", Fprint, Sprint, 1, 2, 0,
 580   "Output the printed representation of OBJECT, with newlines around it.\n\
 581 Quoting characters are printed when needed to make output that `read'\n\
 582 can handle, whenever this is possible.\n\
 583 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
 584   (object, printcharfun)
 585      Lisp_Object object, printcharfun;
 586 {
 587   struct buffer *old = current_buffer;
 588   int old_point = -1;
 589   int start_point;
 590   Lisp_Object original;
 591   struct gcpro gcpro1;
 592
 593 #ifdef MAX_PRINT_CHARS
 594   print_chars = 0;
 595   max_print = MAX_PRINT_CHARS;
 596 #endif /* MAX_PRINT_CHARS */
 597   if (NILP (printcharfun))
 598     printcharfun = Vstandard_output;
 599   GCPRO1 (object);
 600   PRINTPREPARE;
 601   print_depth = 0;
 602   PRINTCHAR ('\n');
 603   print (object, printcharfun, 1);
 604   PRINTCHAR ('\n');
 605   PRINTFINISH;
 606 #ifdef MAX_PRINT_CHARS
 607   max_print = 0;
 608   print_chars = 0;
 609 #endif /* MAX_PRINT_CHARS */
 610   UNGCPRO;
 611   return object;
 612 }
 613
 614 /* The subroutine object for external-debugging-output is kept here
 615    for the convenience of the debugger.  */
 616 Lisp_Object Qexternal_debugging_output;
 617
 618 DEFUN ("external-debugging-output", Fexternal_debugging_output, Sexternal_debugging_output, 1, 1, 0,
 619   "Write CHARACTER to stderr.\n\
 620 You can call print while debugging emacs, and pass it this function\n\
 621 to make it write to the debugging output.\n")
 622   (character)
 623      Lisp_Object character;
 624 {
 625   CHECK_NUMBER (character, 0);
 626   putc (XINT (character), stderr);
 627
 628   return character;
 629 }
 630
 631 /* This is the interface for debugging printing.  */
 632
 633 void
 634 debug_print (arg)
 635      Lisp_Object arg;
 636 {
 637   Fprin1 (arg, Qexternal_debugging_output);
 638   fprintf (stderr, "\r\n");
 639 }
 640 \f
 641 DEFUN ("error-message-string", Ferror_message_string, Serror_message_string,
 642        1, 1, 0,
 643   "Convert an error value (ERROR-SYMBOL . DATA) to an error message.")
 644   (obj)
 645      Lisp_Object obj;
 646 {
 647   struct buffer *old = current_buffer;
 648   Lisp_Object original, printcharfun, value;
 649   struct gcpro gcpro1;
 650
 651   print_error_message (obj, Vprin1_to_string_buffer, NULL);
 652
 653   set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
 654   value = Fbuffer_string ();
 655
 656   GCPRO1 (value);
 657   Ferase_buffer ();
 658   set_buffer_internal (old);
 659   UNGCPRO;
 660
 661   return value;
 662 }
 663
 664 /* Print an error message for the error DATA
 665    onto Lisp output stream STREAM (suitable for the print functions).  */
 666
 667 print_error_message (data, stream)
 668      Lisp_Object data, stream;
 669 {
 670   Lisp_Object errname, errmsg, file_error, tail;
 671   struct gcpro gcpro1;
 672   int i;
 673
 674   errname = Fcar (data);
 675
 676   if (EQ (errname, Qerror))
 677     {
 678       data = Fcdr (data);
 679       if (!CONSP (data)) data = Qnil;
 680       errmsg = Fcar (data);
 681       file_error = Qnil;
 682     }
 683   else
 684     {
 685       errmsg = Fget (errname, Qerror_message);
 686       file_error = Fmemq (Qfile_error,
 687                           Fget (errname, Qerror_conditions));
 688     }
 689
 690   /* Print an error message including the data items.  */
 691
 692   tail = Fcdr_safe (data);
 693   GCPRO1 (tail);
 694
 695   /* For file-error, make error message by concatenating
 696      all the data items.  They are all strings.  */
 697   if (!NILP (file_error) && !NILP (tail))
 698     errmsg = XCONS (tail)->car, tail = XCONS (tail)->cdr;
 699
 700   if (STRINGP (errmsg))
 701     Fprinc (errmsg, stream);
 702   else
 703     write_string_1 ("peculiar error", -1, stream);
 704
 705   for (i = 0; CONSP (tail); tail = Fcdr (tail), i++)
 706     {
 707       write_string_1 (i ? ", " : ": ", 2, stream);
 708       if (!NILP (file_error))
 709         Fprinc (Fcar (tail), stream);
 710       else
 711         Fprin1 (Fcar (tail), stream);
 712     }
 713   UNGCPRO;
 714 }
 715 \f
 716 #ifdef LISP_FLOAT_TYPE
 717
 718 /*
 719  * The buffer should be at least as large as the max string size of the
 720  * largest float, printed in the biggest notation.  This is undoubtedly
 721  * 20d float_output_format, with the negative of the C-constant "HUGE"
 722  * from <math.h>.
 723  *
 724  * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
 725  *
 726  * I assume that IEEE-754 format numbers can take 329 bytes for the worst
 727  * case of -1e307 in 20d float_output_format. What is one to do (short of
 728  * re-writing _doprnt to be more sane)?
 729  *                      -wsr
 730  */
 731
 732 void
 733 float_to_string (buf, data)
 734      unsigned char *buf;
 735      double data;
 736 {
 737   unsigned char *cp;
 738   int width;
 739
 740   if (NILP (Vfloat_output_format)
 741       || !STRINGP (Vfloat_output_format))
 742   lose:
 743     {
 744       sprintf (buf, "%.17g", data);
 745       width = -1;
 746     }
 747   else                  /* oink oink */
 748     {
 749       /* Check that the spec we have is fully valid.
 750          This means not only valid for printf,
 751          but meant for floats, and reasonable.  */
 752       cp = XSTRING (Vfloat_output_format)->data;
 753
 754       if (cp[0] != '%')
 755         goto lose;
 756       if (cp[1] != '.')
 757         goto lose;
 758
 759       cp += 2;
 760
 761       /* Check the width specification.  */
 762       width = -1;
 763       if ('0' <= *cp && *cp <= '9')
 764         {
 765           width = 0;
 766           do
 767             width = (width * 10) + (*cp++ - '0');
 768           while (*cp >= '0' && *cp <= '9');
 769
 770           /* A precision of zero is valid only for %f.  */
 771           if (width > DBL_DIG
 772               || (width == 0 && *cp != 'f'))
 773             goto lose;
 774         }
 775
 776       if (*cp != 'e' && *cp != 'f' && *cp != 'g')
 777         goto lose;
 778
 779       if (cp[1] != 0)
 780         goto lose;
 781
 782       sprintf (buf, XSTRING (Vfloat_output_format)->data, data);
 783     }
 784
 785   /* Make sure there is a decimal point with digit after, or an
 786      exponent, so that the value is readable as a float.  But don't do
 787      this with "%.0f"; it's valid for that not to produce a decimal
 788      point.  Note that width can be 0 only for %.0f.  */
 789   if (width != 0)
 790     {
 791       for (cp = buf; *cp; cp++)
 792         if ((*cp < '0' || *cp > '9') && *cp != '-')
 793           break;
 794
 795       if (*cp == '.' && cp[1] == 0)
 796         {
 797           cp[1] = '0';
 798           cp[2] = 0;
 799         }
 800
 801       if (*cp == 0)
 802         {
 803           *cp++ = '.';
 804           *cp++ = '0';
 805           *cp++ = 0;
 806         }
 807     }
 808 }
 809 #endif /* LISP_FLOAT_TYPE */
 810 \f
 811 static void
 812 print (obj, printcharfun, escapeflag)
 813      Lisp_Object obj;
 814      register Lisp_Object printcharfun;
 815      int escapeflag;
 816 {
 817   char buf[30];
 818
 819   QUIT;
 820
 821 #if 1  /* I'm not sure this is really worth doing.  */
 822   /* Detect circularities and truncate them.
 823      No need to offer any alternative--this is better than an error.  */
 824   if (CONSP (obj) || VECTORP (obj) || COMPILEDP (obj))
 825     {
 826       int i;
 827       for (i = 0; i < print_depth; i++)
 828         if (EQ (obj, being_printed[i]))
 829           {
 830             sprintf (buf, "#%d", i);
 831             strout (buf, -1, printcharfun);
 832             return;
 833           }
 834     }
 835 #endif
 836
 837   being_printed[print_depth] = obj;
 838   print_depth++;
 839
 840   if (print_depth > PRINT_CIRCLE)
 841     error ("Apparently circular structure being printed");
 842 #ifdef MAX_PRINT_CHARS
 843   if (max_print && print_chars > max_print)
 844     {
 845       PRINTCHAR ('\n');
 846       print_chars = 0;
 847     }
 848 #endif /* MAX_PRINT_CHARS */
 849
 850   switch (XGCTYPE (obj))
 851     {
 852     case Lisp_Int:
 853       if (sizeof (int) == sizeof (EMACS_INT))
 854         sprintf (buf, "%d", XINT (obj));
 855       else if (sizeof (long) == sizeof (EMACS_INT))
 856         sprintf (buf, "%ld", XINT (obj));
 857       else
 858         abort ();
 859       strout (buf, -1, printcharfun);
 860       break;
 861
 862 #ifdef LISP_FLOAT_TYPE
 863     case Lisp_Float:
 864       {
 865         char pigbuf[350];       /* see comments in float_to_string */
 866
 867         float_to_string (pigbuf, XFLOAT(obj)->data);
 868         strout (pigbuf, -1, printcharfun);
 869       }
 870       break;
 871 #endif
 872
 873     case Lisp_String:
 874       if (!escapeflag)
 875         print_string (obj, printcharfun);
 876       else
 877         {
 878           register int i;
 879           register unsigned char c;
 880           struct gcpro gcpro1;
 881
 882           GCPRO1 (obj);
 883
 884 #ifdef USE_TEXT_PROPERTIES
 885           if (!NULL_INTERVAL_P (XSTRING (obj)->intervals))
 886             {
 887               PRINTCHAR ('#');
 888               PRINTCHAR ('(');
 889             }
 890 #endif
 891
 892           PRINTCHAR ('\"');
 893           for (i = 0; i < XSTRING (obj)->size; i++)
 894             {
 895               QUIT;
 896               c = XSTRING (obj)->data[i];
 897               if (c == '\n' && print_escape_newlines)
 898                 {
 899                   PRINTCHAR ('\\');
 900                   PRINTCHAR ('n');
 901                 }
 902               else if (c == '\f' && print_escape_newlines)
 903                 {
 904                   PRINTCHAR ('\\');
 905                   PRINTCHAR ('f');
 906                 }
 907               else
 908                 {
 909                   if (c == '\"' || c == '\\')
 910                     PRINTCHAR ('\\');
 911                   PRINTCHAR (c);
 912                 }
 913             }
 914           PRINTCHAR ('\"');
 915
 916 #ifdef USE_TEXT_PROPERTIES
 917           if (!NULL_INTERVAL_P (XSTRING (obj)->intervals))
 918             {
 919               traverse_intervals (XSTRING (obj)->intervals,
 920                                   0, 0, print_interval, printcharfun);
 921               PRINTCHAR (')');
 922             }
 923 #endif
 924
 925           UNGCPRO;
 926         }
 927       break;
 928
 929     case Lisp_Symbol:
 930       {
 931         register int confusing;
 932         register unsigned char *p = XSYMBOL (obj)->name->data;
 933         register unsigned char *end = p + XSYMBOL (obj)->name->size;
 934         register unsigned char c;
 935
 936         if (p != end && (*p == '-' || *p == '+')) p++;
 937         if (p == end)
 938           confusing = 0;
 939         else
 940           {
 941             while (p != end && *p >= '0' && *p <= '9')
 942               p++;
 943             confusing = (end == p);
 944           }
 945
 946         p = XSYMBOL (obj)->name->data;
 947         while (p != end)
 948           {
 949             QUIT;
 950             c = *p++;
 951             if (escapeflag)
 952               {
 953                 if (c == '\"' || c == '\\' || c == '\'' || c == ';' || c == '#' ||
 954                     c == '(' || c == ')' || c == ',' || c =='.' || c == '`' ||
 955                     c == '[' || c == ']' || c == '?' || c <= 040 || confusing)
 956                   PRINTCHAR ('\\'), confusing = 0;
 957               }
 958             PRINTCHAR (c);
 959           }
 960       }
 961       break;
 962
 963     case Lisp_Cons:
 964       /* If deeper than spec'd depth, print placeholder.  */
 965       if (INTEGERP (Vprint_level)
 966           && print_depth > XINT (Vprint_level))
 967         strout ("...", -1, printcharfun);
 968       else
 969         {
 970           PRINTCHAR ('(');
 971           {
 972             register int i = 0;
 973             register int max = 0;
 974
 975             if (INTEGERP (Vprint_length))
 976               max = XINT (Vprint_length);
 977             /* Could recognize circularities in cdrs here,
 978                but that would make printing of long lists quadratic.
 979                It's not worth doing.  */
 980             while (CONSP (obj))
 981               {
 982                 if (i++)
 983                   PRINTCHAR (' ');
 984                 if (max && i > max)
 985                   {
 986                     strout ("...", 3, printcharfun);
 987                     break;
 988                   }
 989                 print (Fcar (obj), printcharfun, escapeflag);
 990                 obj = Fcdr (obj);
 991               }
 992           }
 993           if (!NILP (obj) && !CONSP (obj))
 994             {
 995               strout (" . ", 3, printcharfun);
 996               print (obj, printcharfun, escapeflag);
 997             }
 998           PRINTCHAR (')');
 999         }
1000       break;
1001
1002     case Lisp_Vectorlike:
1003       if (PROCESSP (obj))
1004         {
1005           if (escapeflag)
1006             {
1007               strout ("#<process ", -1, printcharfun);
1008               print_string (XPROCESS (obj)->name, printcharfun);
1009               PRINTCHAR ('>');
1010             }
1011           else
1012             print_string (XPROCESS (obj)->name, printcharfun);
1013         }
1014       else if (BOOL_VECTOR_P (obj))
1015         {
1016           register int i;
1017           register unsigned char c;
1018           struct gcpro gcpro1;
1019           int size_in_chars
1020             = (XBOOL_VECTOR (obj)->size + BITS_PER_CHAR) / BITS_PER_CHAR;
1021
1022           GCPRO1 (obj);
1023
1024           PRINTCHAR ('#');
1025           PRINTCHAR ('&');
1026           sprintf (buf, "%d", XBOOL_VECTOR (obj)->size);
1027           strout (buf, -1, printcharfun);
1028           PRINTCHAR ('\"');
1029
1030           /* Don't print more characters than the specified maximum.  */
1031           if (INTEGERP (Vprint_length)
1032               && XINT (Vprint_length) < size_in_chars)
1033             size_in_chars = XINT (Vprint_length);
1034
1035           for (i = 0; i < size_in_chars; i++)
1036             {
1037               QUIT;
1038               c = XBOOL_VECTOR (obj)->data[i];
1039               if (c == '\n' && print_escape_newlines)
1040                 {
1041                   PRINTCHAR ('\\');
1042                   PRINTCHAR ('n');
1043                 }
1044               else if (c == '\f' && print_escape_newlines)
1045                 {
1046                   PRINTCHAR ('\\');
1047                   PRINTCHAR ('f');
1048                 }
1049               else
1050                 {
1051                   if (c == '\"' || c == '\\')
1052                     PRINTCHAR ('\\');
1053                   PRINTCHAR (c);
1054                 }
1055             }
1056           PRINTCHAR ('\"');
1057
1058           UNGCPRO;
1059         }
1060       else if (SUBRP (obj))
1061         {
1062           strout ("#<subr ", -1, printcharfun);
1063           strout (XSUBR (obj)->symbol_name, -1, printcharfun);
1064           PRINTCHAR ('>');
1065         }
1066 #ifndef standalone
1067       else if (WINDOWP (obj))
1068         {
1069           strout ("#<window ", -1, printcharfun);
1070           sprintf (buf, "%d", XFASTINT (XWINDOW (obj)->sequence_number));
1071           strout (buf, -1, printcharfun);
1072           if (!NILP (XWINDOW (obj)->buffer))
1073             {
1074               strout (" on ", -1, printcharfun);
1075               print_string (XBUFFER (XWINDOW (obj)->buffer)->name, printcharfun);
1076             }
1077           PRINTCHAR ('>');
1078         }
1079       else if (BUFFERP (obj))
1080         {
1081           if (NILP (XBUFFER (obj)->name))
1082             strout ("#<killed buffer>", -1, printcharfun);
1083           else if (escapeflag)
1084             {
1085               strout ("#<buffer ", -1, printcharfun);
1086               print_string (XBUFFER (obj)->name, printcharfun);
1087               PRINTCHAR ('>');
1088             }
1089           else
1090             print_string (XBUFFER (obj)->name, printcharfun);
1091         }
1092       else if (WINDOW_CONFIGURATIONP (obj))
1093         {
1094           strout ("#<window-configuration>", -1, printcharfun);
1095         }
1096 #ifdef MULTI_FRAME
1097       else if (FRAMEP (obj))
1098         {
1099           strout ((FRAME_LIVE_P (XFRAME (obj))
1100                    ? "#<frame " : "#<dead frame "),
1101                   -1, printcharfun);
1102           print_string (XFRAME (obj)->name, printcharfun);
1103           sprintf (buf, " 0x%lx", (unsigned long) (XFRAME (obj)));
1104           strout (buf, -1, printcharfun);
1105           PRINTCHAR ('>');
1106         }
1107 #endif
1108 #endif /* not standalone */
1109       else
1110         {
1111           int size = XVECTOR (obj)->size;
1112           if (COMPILEDP (obj))
1113             {
1114               PRINTCHAR ('#');
1115               size &= PSEUDOVECTOR_SIZE_MASK;
1116             }
1117           if (CHAR_TABLE_P (obj))
1118             {
1119               /* We print a char-table as if it were a vector,
1120                  lumping the parent and default slots in with the
1121                  character slots.  But we add #^ as a prefix.  */
1122               PRINTCHAR ('#');
1123               PRINTCHAR ('^');
1124               size &= PSEUDOVECTOR_SIZE_MASK;
1125             }
1126           if (size & PSEUDOVECTOR_FLAG)
1127             goto badtype;
1128
1129           PRINTCHAR ('[');
1130           {
1131             register int i;
1132             register Lisp_Object tem;
1133
1134             /* Don't print more elements than the specified maximum.  */
1135             if (INTEGERP (Vprint_length)
1136                 && XINT (Vprint_length) < size)
1137               size = XINT (Vprint_length);
1138
1139             for (i = 0; i < size; i++)
1140               {
1141                 if (i) PRINTCHAR (' ');
1142                 tem = XVECTOR (obj)->contents[i];
1143                 print (tem, printcharfun, escapeflag);
1144               }
1145           }
1146           PRINTCHAR (']');
1147         }
1148       break;
1149
1150 #ifndef standalone
1151     case Lisp_Misc:
1152       switch (XMISCTYPE (obj))
1153         {
1154         case Lisp_Misc_Marker:
1155           strout ("#<marker ", -1, printcharfun);
1156           if (!(XMARKER (obj)->buffer))
1157             strout ("in no buffer", -1, printcharfun);
1158           else
1159             {
1160               sprintf (buf, "at %d", marker_position (obj));
1161               strout (buf, -1, printcharfun);
1162               strout (" in ", -1, printcharfun);
1163               print_string (XMARKER (obj)->buffer->name, printcharfun);
1164             }
1165           PRINTCHAR ('>');
1166           break;
1167
1168         case Lisp_Misc_Overlay:
1169           strout ("#<overlay ", -1, printcharfun);
1170           if (!(XMARKER (OVERLAY_START (obj))->buffer))
1171             strout ("in no buffer", -1, printcharfun);
1172           else
1173             {
1174               sprintf (buf, "from %d to %d in ",
1175                        marker_position (OVERLAY_START (obj)),
1176                        marker_position (OVERLAY_END   (obj)));
1177               strout (buf, -1, printcharfun);
1178               print_string (XMARKER (OVERLAY_START (obj))->buffer->name,
1179                             printcharfun);
1180             }
1181           PRINTCHAR ('>');
1182           break;
1183
1184       /* Remaining cases shouldn't happen in normal usage, but let's print
1185          them anyway for the benefit of the debugger.  */
1186         case Lisp_Misc_Free:
1187           strout ("#<misc free cell>", -1, printcharfun);
1188           break;
1189
1190         case Lisp_Misc_Intfwd:
1191           sprintf (buf, "#<intfwd to %d>", *XINTFWD (obj)->intvar);
1192           strout (buf, -1, printcharfun);
1193           break;
1194
1195         case Lisp_Misc_Boolfwd:
1196           sprintf (buf, "#<boolfwd to %s>",
1197                    (*XBOOLFWD (obj)->boolvar ? "t" : "nil"));
1198           strout (buf, -1, printcharfun);
1199           break;
1200
1201         case Lisp_Misc_Objfwd:
1202           strout ("#<objfwd to ", -1, printcharfun);
1203           print (*XOBJFWD (obj)->objvar, printcharfun, escapeflag);
1204           PRINTCHAR ('>');
1205           break;
1206
1207         case Lisp_Misc_Buffer_Objfwd:
1208           strout ("#<buffer_objfwd to ", -1, printcharfun);
1209           print (*(Lisp_Object *)((char *)current_buffer
1210                                   + XBUFFER_OBJFWD (obj)->offset),
1211                  printcharfun, escapeflag);
1212           PRINTCHAR ('>');
1213           break;
1214
1215         case Lisp_Misc_Kboard_Objfwd:
1216           strout ("#<kboard_objfwd to ", -1, printcharfun);
1217           print (*(Lisp_Object *)((char *) current_kboard
1218                                   + XKBOARD_OBJFWD (obj)->offset),
1219                  printcharfun, escapeflag);
1220           PRINTCHAR ('>');
1221           break;
1222
1223         case Lisp_Misc_Buffer_Local_Value:
1224           strout ("#<buffer_local_value ", -1, printcharfun);
1225           goto do_buffer_local;
1226         case Lisp_Misc_Some_Buffer_Local_Value:
1227           strout ("#<some_buffer_local_value ", -1, printcharfun);
1228         do_buffer_local:
1229           strout ("[realvalue] ", -1, printcharfun);
1230           print (XBUFFER_LOCAL_VALUE (obj)->car, printcharfun, escapeflag);
1231           strout ("[buffer] ", -1, printcharfun);
1232           print (XCONS (XBUFFER_LOCAL_VALUE (obj)->cdr)->car,
1233                  printcharfun, escapeflag);
1234           strout ("[alist-elt] ", -1, printcharfun);
1235           print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj)->cdr)->cdr)->car,
1236                  printcharfun, escapeflag);
1237           strout ("[default-value] ", -1, printcharfun);
1238           print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj)->cdr)->cdr)->cdr,
1239                  printcharfun, escapeflag);
1240           PRINTCHAR ('>');
1241           break;
1242
1243         default:
1244           goto badtype;
1245         }
1246       break;
1247 #endif /* standalone */
1248
1249     default:
1250     badtype:
1251       {
1252         /* We're in trouble if this happens!
1253            Probably should just abort () */
1254         strout ("#<EMACS BUG: INVALID DATATYPE ", -1, printcharfun);
1255         if (MISCP (obj))
1256           sprintf (buf, "(MISC 0x%04x)", (int) XMISCTYPE (obj));
1257         else if (VECTORLIKEP (obj))
1258           sprintf (buf, "(PVEC 0x%08x)", (int) XVECTOR (obj)->size);
1259         else
1260           sprintf (buf, "(0x%02x)", (int) XTYPE (obj));
1261         strout (buf, -1, printcharfun);
1262         strout (" Save your buffers immediately and please report this bug>",
1263                 -1, printcharfun);
1264       }
1265     }
1266
1267   print_depth--;
1268 }
1269 \f
1270 #ifdef USE_TEXT_PROPERTIES
1271
1272 /* Print a description of INTERVAL using PRINTCHARFUN.
1273    This is part of printing a string that has text properties.  */
1274
1275 void
1276 print_interval (interval, printcharfun)
1277      INTERVAL interval;
1278      Lisp_Object printcharfun;
1279 {
1280   PRINTCHAR (' ');
1281   print (make_number (interval->position), printcharfun, 1);
1282   PRINTCHAR (' ');
1283   print (make_number (interval->position + LENGTH (interval)),
1284          printcharfun, 1);
1285   PRINTCHAR (' ');
1286   print (interval->plist, printcharfun, 1);
1287 }
1288
1289 #endif /* USE_TEXT_PROPERTIES */
1290 \f
1291 void
1292 syms_of_print ()
1293 {
1294   staticpro (&Qprint_escape_newlines);
1295   Qprint_escape_newlines = intern ("print-escape-newlines");
1296
1297   DEFVAR_LISP ("standard-output", &Vstandard_output,
1298     "Output stream `print' uses by default for outputting a character.\n\
1299 This may be any function of one argument.\n\
1300 It may also be a buffer (output is inserted before point)\n\
1301 or a marker (output is inserted and the marker is advanced)\n\
1302 or the symbol t (output appears in the echo area).");
1303   Vstandard_output = Qt;
1304   Qstandard_output = intern ("standard-output");
1305   staticpro (&Qstandard_output);
1306
1307 #ifdef LISP_FLOAT_TYPE
1308   DEFVAR_LISP ("float-output-format", &Vfloat_output_format,
1309     "The format descriptor string used to print floats.\n\
1310 This is a %-spec like those accepted by `printf' in C,\n\
1311 but with some restrictions.  It must start with the two characters `%.'.\n\
1312 After that comes an integer precision specification,\n\
1313 and then a letter which controls the format.\n\
1314 The letters allowed are `e', `f' and `g'.\n\
1315 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"\n\
1316 Use `f' for decimal point notation \"DIGITS.DIGITS\".\n\
1317 Use `g' to choose the shorter of those two formats for the number at hand.\n\
1318 The precision in any of these cases is the number of digits following\n\
1319 the decimal point.  With `f', a precision of 0 means to omit the\n\
1320 decimal point.  0 is not allowed with `e' or `g'.\n\n\
1321 A value of nil means to use `%.17g'.");
1322   Vfloat_output_format = Qnil;
1323   Qfloat_output_format = intern ("float-output-format");
1324   staticpro (&Qfloat_output_format);
1325 #endif /* LISP_FLOAT_TYPE */
1326
1327   DEFVAR_LISP ("print-length", &Vprint_length,
1328     "Maximum length of list to print before abbreviating.\n\
1329 A value of nil means no limit.");
1330   Vprint_length = Qnil;
1331
1332   DEFVAR_LISP ("print-level", &Vprint_level,
1333     "Maximum depth of list nesting to print before abbreviating.\n\
1334 A value of nil means no limit.");
1335   Vprint_level = Qnil;
1336
1337   DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines,
1338     "Non-nil means print newlines in strings as backslash-n.\n\
1339 Also print formfeeds as backslash-f.");
1340   print_escape_newlines = 0;
1341
1342   /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
1343   staticpro (&Vprin1_to_string_buffer);
1344
1345   defsubr (&Sprin1);
1346   defsubr (&Sprin1_to_string);
1347   defsubr (&Serror_message_string);
1348   defsubr (&Sprinc);
1349   defsubr (&Sprint);
1350   defsubr (&Sterpri);
1351   defsubr (&Swrite_char);
1352   defsubr (&Sexternal_debugging_output);
1353
1354   Qexternal_debugging_output = intern ("external-debugging-output");
1355   staticpro (&Qexternal_debugging_output);
1356
1357 #ifndef standalone
1358   defsubr (&Swith_output_to_temp_buffer);
1359 #endif /* not standalone */
1360 }