src/print.c

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