cgit.sxemacs.org Git - sxemacs/blob - src/print.c

   1 /* Lisp object printing and output streams.
   2    Copyright (C) 1985, 1986, 1988, 1992-1995 Free Software Foundation, Inc.
   3    Copyright (C) 1995, 1996, 2000, 2002 Ben Wing.
   4
   5 This file is part of SXEmacs
   6
   7 SXEmacs is free software: you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation, either version 3 of the License, or
  10 (at your option) any later version.
  11
  12 SXEmacs is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with this program.  If not, see <http://www.gnu.org/licenses/>. */
  19
  20
  21 /* Synched up with: Not synched with FSF. */
  22
  23 /* This file has been Mule-ized. */
  24
  25 /* Seriously hacked on by Ben Wing for Mule. */
  26
  27 #include <config.h>
  28 #include "lisp.h"
  29
  30 #include "backtrace.h"
  31 #include "buffer.h"
  32 #include "bytecode.h"
  33 #include "ui/TTY/console-tty.h" /* for stuff in
  34                                    write_string_to_stdio_stream. Needs
  35                                    refacturing */
  36 #include "ui/console-stream.h"
  37 #include "extents.h"
  38 #include "ui/frame.h"
  39 #include "ui/insdel.h"
  40 #include "lstream.h"
  41 #include "sysfile.h"
  42
  43 #include <float.h>
  44 /* Define if not in float.h */
  45 #ifndef DBL_DIG
  46 #define DBL_DIG 16
  47 #endif
  48
  49 Lisp_Object Vstandard_output, Qstandard_output;
  50
  51 /* The subroutine object for external-debugging-output is kept here
  52    for the convenience of the debugger.  */
  53 Lisp_Object Qexternal_debugging_output, Qalternate_debugging_output;
  54
  55 /* Avoid actual stack overflow in print.  */
  56 static int print_depth;
  57
  58 /* Detect most circularities to print finite output.  */
  59 #define PRINT_CIRCLE 200
  60 static Lisp_Object being_printed[PRINT_CIRCLE];
  61
  62 /* Maximum length of list or vector to print in full; noninteger means
  63    effectively infinity */
  64
  65 Lisp_Object Vprint_length;
  66 Lisp_Object Qprint_length;
  67
  68 /* Maximum length of string to print in full; noninteger means
  69    effectively infinity */
  70
  71 Lisp_Object Vprint_string_length;
  72 Lisp_Object Qprint_string_length;
  73
  74 /* Maximum depth of list to print in full; noninteger means
  75    effectively infinity.  */
  76
  77 Lisp_Object Vprint_level;
  78
  79 /* Label to use when making echo-area messages. */
  80
  81 Lisp_Object Vprint_message_label;
  82
  83 /* Nonzero means print newlines in strings as \n.  */
  84
  85 int print_escape_newlines;
  86 int print_readably;
  87
  88 /* Non-nil means print #: before uninterned symbols.
  89    Neither t nor nil means so that and don't clear Vprint_gensym_alist
  90    on entry to and exit from print functions.  */
  91 Lisp_Object Vprint_gensym;
  92 Lisp_Object Vprint_gensym_alist;
  93
  94 Lisp_Object Qdisplay_error;
  95 Lisp_Object Qprint_message_label;
  96
  97 Lisp_Object Vcustom_object_printer;
  98
  99 /* Force immediate output of all printed data.  Used for debugging. */
 100 int print_unbuffered;
 101
 102 FILE *termscript;               /* Stdio stream being used for copy of all output.  */
 103 \f
 104 int stdout_needs_newline;
 105
 106 void debug_backtrace(void);
 107
 108 static void
 109 std_handle_out_external(FILE * stream, Lisp_Object lstream,
 110                         const Extbyte * extptr, Extcount extlen,
 111                         /* is this really stdout/stderr?
 112                            (controls termscript writing) */
 113                         int output_is_std_handle, int must_flush)
 114 {
 115         assert(extptr != NULL);
 116
 117         if ( extlen == 0 ) {
 118                 stdout_needs_newline = 1;
 119                 return;
 120         }
 121         if (stream) {
 122                 fwrite(extptr, 1, extlen, stream);
 123                 if (must_flush) fflush(stream);
 124         } else
 125                 Lstream_write(XLSTREAM(lstream), extptr, extlen);
 126
 127         if (output_is_std_handle) {
 128                 if (termscript) {
 129                         fwrite(extptr, 1, extlen, termscript);
 130                         fflush(termscript);
 131                 }
 132                 stdout_needs_newline = extptr[extlen - 1] != '\n';
 133         }
 134 }
 135
 136
 137 #define SXE_VSNPRINT_VA(ret__,sbuf__,buf__,size__,spec__,tries__,type__,fmt__,args__) \
 138         do {                                                            \
 139                 --tries__;                                              \
 140                 ret__ = vsnprintf((char*)buf__,size__,fmt__,args__);    \
 141                 if ( ret__ == 0 ) {                                     \
 142                         /* Nothing to write */                          \
 143                         break;                                          \
 144                 } else if ( ret__ < 0 ) {                               \
 145                         XMALLOC_UNBIND(buf__,size__,spec__);            \
 146                         size__ *= 2;                                    \
 147                         XMALLOC_OR_ALLOCA(buf__,size__,type__);         \
 148                 } else if ( (size_t)ret__ > (size_t)size__ ) {          \
 149                     /* We need more space, so we need to allocate it */ \
 150                         XMALLOC_UNBIND(buf__,size__,spec__);            \
 151                         size__ = ret__ + 1;                             \
 152                         XMALLOC_OR_ALLOCA(buf__,size__,type__);         \
 153                         ret__ = -1;                                     \
 154                 }                                                       \
 155         } while( ret__ < 0 && tries__ > 0 )
 156
 157
 158 int write_fmt_str(Lisp_Object stream, const char* fmt, ...)
 159 {
 160         char   *kludge;
 161         va_list args;
 162         int     bufsize, retval, tries = 3;
 163         /* write_fmt_str is used for small prints usually... */
 164         char    buffer[64+1];
 165         int speccount = specpdl_depth();
 166
 167         va_start(args, fmt);
 168         kludge = buffer;
 169         bufsize = sizeof(buffer);
 170
 171         SXE_VSNPRINT_VA(retval,buffer,kludge,bufsize,speccount,tries,char,fmt,args);
 172
 173         if (retval>0)
 174                 write_c_string(kludge,stream);
 175
 176         XMALLOC_UNBIND(kludge, bufsize, speccount);
 177         va_end(args);
 178
 179         if (retval < 0)
 180                 error("Error attempting to write write format string '%s'",
 181                       fmt);
 182         return retval;
 183 }
 184
 185 int write_fmt_string(Lisp_Object stream, const char *fmt, ...)
 186 {
 187         char   *kludge;
 188         va_list args;
 189         int     bufsize, retval, tries = 3;
 190         /* write_va is used for small prints usually... */
 191         char    buffer[128+1];
 192         int speccount = specpdl_depth();
 193
 194         va_start(args, fmt);
 195         kludge = buffer;
 196         bufsize = sizeof(buffer);
 197
 198         SXE_VSNPRINT_VA(retval,buffer,kludge,bufsize,speccount,tries,char,fmt,args);
 199         if (retval>0)
 200                 write_c_string(kludge,stream);
 201         XMALLOC_UNBIND(kludge, bufsize, speccount);
 202         va_end(args);
 203
 204         if (retval < 0)
 205                 error("Error attempting to write write format string '%s'",
 206                       fmt);
 207         return retval;
 208 }
 209
 210 /* #### The following function should be replaced a call to the
 211    emacs_doprnt_*() functions.  This is the only way to ensure that
 212    I18N3 works properly (many implementations of the *printf()
 213    functions, including the ones included in glibc, do not implement
 214    the %###$ argument-positioning syntax).
 215
 216    Note, however, that to do this, we'd have to
 217
 218    1) pre-allocate all the lstreams and do whatever else was necessary
 219    to make sure that no allocation occurs, since these functions may be
 220    called from fatal_error_signal().
 221
 222    2) (to be really correct) make a new lstream that outputs using
 223    mswindows_output_console_string().  */
 224
 225 static int std_handle_out_va(FILE * stream, const char *fmt, va_list args)
 226 {
 227         int      retval, tries = 3;
 228         size_t   bufsize;
 229         int      use_fprintf;
 230         Bufbyte *kludge;
 231         Bufbyte  buffer[1024]; /* Tax stack lightly, used to be 16KiB */
 232         int      speccount = specpdl_depth();
 233
 234         bufsize = sizeof(buffer);
 235         kludge = buffer;
 236
 237         SXE_VSNPRINT_VA(retval,buffer,kludge,bufsize,speccount,tries,Bufbyte,fmt,args);
 238
 239         if (retval == 0)
 240                 /* nothing to write */
 241                 return retval;
 242
 243         use_fprintf = ! initialized ||fatal_error_in_progress ||
 244                 inhibit_non_essential_printing_operations;
 245
 246         if (retval > 0) {
 247                 if (use_fprintf) {
 248                         fprintf(stream,"%s",(char*)kludge);
 249                 } else {
 250                         Extbyte  *extptr = NULL;
 251                         Extcount extlen = retval;
 252
 253                         TO_EXTERNAL_FORMAT(DATA, (kludge, strlen((char *)kludge)),
 254                                            ALLOCA, (extptr, extlen), Qnative);
 255                         std_handle_out_external(stream, Qnil, extptr, extlen, 1, 1);
 256                 }
 257         } else {
 258                 if (use_fprintf) {
 259                         fprintf(stream,"Error attempting to write format string '%s'",
 260                                 fmt);
 261                 } else {
 262                         const Extbyte *msg = "Error attempting to write format string";
 263                         std_handle_out_external(stream, Qnil, msg, strlen(msg), 1, 1);
 264                 }
 265         }
 266         XMALLOC_UNBIND(kludge, bufsize, speccount);
 267         return retval;
 268 }
 269
 270
 271 /* Output portably to stderr or its equivalent; call GETTEXT on the
 272    format string.  Automatically flush when done. */
 273
 274 int stderr_out(const char *fmt, ...)
 275 {
 276         int retval;
 277         va_list args;
 278         va_start(args, fmt);
 279         retval =
 280             std_handle_out_va
 281             (stderr, initialized
 282              && !fatal_error_in_progress ? GETTEXT(fmt) : fmt, args);
 283         va_end(args);
 284         return retval;
 285 }
 286
 287 /* Output portably to stdout or its equivalent; call GETTEXT on the
 288    format string.  Automatically flush when done. */
 289
 290 int stdout_out(const char *fmt, ...)
 291 {
 292         int retval;
 293         va_list args;
 294         va_start(args, fmt);
 295         retval = std_handle_out_va(stdout,
 296                                    (initialized && !fatal_error_in_progress
 297                                     ? GETTEXT(fmt) : fmt),
 298                                    args);
 299         va_end(args);
 300         return retval;
 301 }
 302
 303 DOESNT_RETURN fatal(const char *fmt, ...)
 304 {
 305         va_list args;
 306         va_start(args, fmt);
 307
 308         stderr_out("\nSXEmacs: ");
 309         std_handle_out_va(stderr,
 310                           (initialized && !fatal_error_in_progress
 311                            ? GETTEXT(fmt) : fmt),
 312                           args);
 313         stderr_out("\n");
 314
 315         va_end(args);
 316         exit(1);
 317 }
 318
 319 /* Write a string (in internal format) to stdio stream STREAM. */
 320
 321 void
 322 write_string_to_stdio_stream(FILE * stream, struct console *con,
 323                              const Bufbyte * str,
 324                              Bytecount offset, Bytecount len,
 325                              Lisp_Object coding_system, int must_flush)
 326 {
 327         Extcount extlen;
 328         const Extbyte *extptr;
 329
 330         /* #### yuck! sometimes this function is called with string data,
 331            and the following call may gc. */
 332         {
 333                 Bufbyte *puta = (Bufbyte *) alloca(len);
 334                 memcpy(puta, str + offset, len);
 335
 336                 if (initialized && !inhibit_non_essential_printing_operations)
 337                         TO_EXTERNAL_FORMAT(DATA, (puta, len),
 338                                            ALLOCA, (extptr, extlen),
 339                                            coding_system);
 340                 else {
 341                         extptr = (Extbyte *) puta;
 342                         extlen = (Bytecount) len;
 343                 }
 344         }
 345
 346
 347         if (stream) {
 348                 std_handle_out_external(stream, Qnil, extptr, extlen,
 349                                         stream == stdout
 350                                         || stream == stderr, must_flush);
 351         } else if(con != NULL) {
 352                 assert(CONSOLE_TTY_P(con));
 353                 std_handle_out_external(0, CONSOLE_TTY_DATA(con)->outstream,
 354                                         extptr, extlen,
 355                                         CONSOLE_TTY_DATA(con)->is_stdio,
 356                                         must_flush);
 357         } else {
 358                 error("Error attempting to write write '%s' with no stream nor console", str);
 359                 debug_backtrace();
 360                 abort();
 361         }
 362 }
 363
 364 /* Write a string to the output location specified in FUNCTION.
 365    Arguments NONRELOC, RELOC, OFFSET, and LEN are as in
 366    buffer_insert_string_1() in insdel.c. */
 367
 368 static void
 369 output_string(Lisp_Object function, const Bufbyte * nonreloc,
 370               Lisp_Object reloc, Bytecount offset, Bytecount len)
 371 {
 372         /* This function can GC */
 373         Charcount cclen;
 374         /* We change the value of nonreloc (fetching it from reloc as
 375            necessary), but we don't want to pass this changed value on to
 376            other functions that take both a nonreloc and a reloc, or things
 377            may get confused and an assertion failure in
 378            fixup_internal_substring() may get triggered. */
 379         const Bufbyte *newnonreloc = nonreloc;
 380         struct gcpro gcpro1, gcpro2;
 381
 382         /* Emacs won't print while GCing, but an external debugger might */
 383         if (gc_in_progress)
 384                 return;
 385
 386         /* Perhaps not necessary but probably safer. */
 387         GCPRO2(function, reloc);
 388
 389         fixup_internal_substring(newnonreloc, reloc, offset, &len);
 390
 391         if (STRINGP(reloc))
 392                 newnonreloc = XSTRING_DATA(reloc);
 393
 394         cclen = bytecount_to_charcount(newnonreloc + offset, len);
 395
 396         if (LSTREAMP(function)) {
 397                 if (STRINGP(reloc)) {
 398                         /* Protect against Lstream_write() causing a GC and
 399                            relocating the string.  For small strings, we do it by
 400                            alloc'ing the string and using a copy; for large strings,
 401                            we inhibit GC.  */
 402                         if (len < 65536) {
 403                                 Bufbyte *copied = alloca_array(Bufbyte, len);
 404                                 memcpy(copied, newnonreloc + offset, len);
 405                                 Lstream_write(XLSTREAM(function), copied, len);
 406                         } else {
 407                                 int speccount = specpdl_depth();
 408                                 record_unwind_protect(restore_gc_inhibit,
 409                                                       make_int
 410                                                       (gc_currently_forbidden));
 411                                 gc_currently_forbidden = 1;
 412                                 Lstream_write(XLSTREAM(function),
 413                                               newnonreloc + offset, len);
 414                                 unbind_to(speccount, Qnil);
 415                         }
 416                 } else
 417                         Lstream_write(XLSTREAM(function), newnonreloc + offset,
 418                                       len);
 419
 420                 if (print_unbuffered)
 421                         Lstream_flush(XLSTREAM(function));
 422         } else if (BUFFERP(function)) {
 423                 CHECK_LIVE_BUFFER(function);
 424                 buffer_insert_string(XBUFFER(function), nonreloc, reloc, offset,
 425                                      len);
 426         } else if (MARKERP(function)) {
 427                 /* marker_position() will err if marker doesn't point anywhere.  */
 428                 Bufpos spoint = marker_position(function);
 429
 430                 buffer_insert_string_1(XMARKER(function)->buffer,
 431                                        spoint, nonreloc, reloc, offset, len, 0);
 432                 Fset_marker(function, make_int(spoint + cclen),
 433                             Fmarker_buffer(function));
 434         } else if (FRAMEP(function)) {
 435                 /* This gets used by functions not invoking print_prepare(),
 436                    such as Fwrite_char, Fterpri, etc..  */
 437                 struct frame *f = XFRAME(function);
 438                 CHECK_LIVE_FRAME(function);
 439
 440                 if (!EQ(Vprint_message_label, echo_area_status(f)))
 441                         clear_echo_area_from_print(f, Qnil, 1);
 442                 echo_area_append(f, nonreloc, reloc, offset, len,
 443                                  Vprint_message_label);
 444         } else if (EQ(function, Qt) || EQ(function, Qnil)) {
 445                 write_string_to_stdio_stream(stdout, 0, newnonreloc, offset,
 446                                              len, Qterminal, print_unbuffered);
 447         } else {
 448                 Charcount ccoff = bytecount_to_charcount(newnonreloc, offset);
 449                 Charcount iii;
 450
 451                 for (iii = ccoff; iii < cclen + ccoff; iii++) {
 452                         call1(function,
 453                               make_char(charptr_emchar_n(newnonreloc, iii)));
 454                         if (STRINGP(reloc))
 455                                 newnonreloc = XSTRING_DATA(reloc);
 456                 }
 457         }
 458
 459         UNGCPRO;
 460 }
 461 \f
 462 #define RESET_PRINT_GENSYM do {                 \
 463   if (!CONSP (Vprint_gensym))                   \
 464     Vprint_gensym_alist = Qnil;                 \
 465 } while (0)
 466
 467 static Lisp_Object canonicalize_printcharfun(Lisp_Object printcharfun)
 468 {
 469         if (NILP(printcharfun))
 470                 printcharfun = Vstandard_output;
 471
 472         if (EQ(printcharfun, Qt) || NILP(printcharfun))
 473                 printcharfun = Fselected_frame(Qnil);   /* print to minibuffer */
 474
 475         return printcharfun;
 476 }
 477
 478 static Lisp_Object
 479 print_prepare(Lisp_Object printcharfun, Lisp_Object * frame_kludge)
 480 {
 481         /* Emacs won't print while GCing, but an external debugger might */
 482         if (gc_in_progress)
 483                 return Qnil;
 484
 485         RESET_PRINT_GENSYM;
 486
 487         printcharfun = canonicalize_printcharfun(printcharfun);
 488
 489         /* Here we could safely return the canonicalized PRINTCHARFUN.
 490            However, if PRINTCHARFUN is a frame, printing of complex
 491            structures becomes very expensive, because `append-message'
 492            (called by echo_area_append) gets called as many times as
 493            output_string() is called (and that's a *lot*).  append-message
 494            tries to keep top of the message-stack in sync with the contents
 495            of " *Echo Area" buffer, consing a new string for each component
 496            of the printed structure.  For instance, if you print (a a),
 497            append-message will cons up the following strings:
 498
 499            "("
 500            "(a"
 501            "(a "
 502            "(a a"
 503            "(a a)"
 504
 505            and will use only the last one.  With larger objects, this turns
 506            into an O(n^2) consing frenzy that locks up SXEmacs in incessant
 507            garbage collection.
 508
 509            We prevent this by creating a resizing_buffer stream and letting
 510            the printer write into it.  print_finish() will notice this
 511            stream, and invoke echo_area_append() with the stream's buffer,
 512            only once.  */
 513         if (FRAMEP(printcharfun)) {
 514                 CHECK_LIVE_FRAME(printcharfun);
 515                 *frame_kludge = printcharfun;
 516                 printcharfun = make_resizing_buffer_output_stream();
 517         }
 518
 519         return printcharfun;
 520 }
 521
 522 static void print_finish(Lisp_Object stream, Lisp_Object frame_kludge)
 523 {
 524         /* Emacs won't print while GCing, but an external debugger might */
 525         if (gc_in_progress)
 526                 return;
 527
 528         RESET_PRINT_GENSYM;
 529
 530         /* See the comment in print_prepare().  */
 531         if (FRAMEP(frame_kludge)) {
 532                 struct frame *f = XFRAME(frame_kludge);
 533                 Lstream *str = XLSTREAM(stream);
 534                 CHECK_LIVE_FRAME(frame_kludge);
 535
 536                 Lstream_flush(str);
 537                 if (!EQ(Vprint_message_label, echo_area_status(f)))
 538                         clear_echo_area_from_print(f, Qnil, 1);
 539                 echo_area_append(f, resizing_buffer_stream_ptr(str),
 540                                  Qnil, 0, Lstream_byte_count(str),
 541                                  Vprint_message_label);
 542                 Lstream_delete(str);
 543         }
 544 }
 545 \f
 546 /* Used for printing a single-byte character (*not* any Emchar).  */
 547 #define write_char_internal(string_of_length_1, stream)                 \
 548   output_string (stream, (const Bufbyte *) (string_of_length_1),        \
 549                  Qnil, 0, 1)
 550
 551 /* NOTE: Do not call this with the data of a Lisp_String, as
 552    printcharfun might cause a GC, which might cause the string's data
 553    to be relocated.  To princ a Lisp string, use:
 554
 555        print_internal (string, printcharfun, 0);
 556
 557    Also note that STREAM should be the result of
 558    canonicalize_printcharfun() (i.e. Qnil means stdout, not
 559    Vstandard_output, etc.)  */
 560 void write_string_1(const Bufbyte * str, Bytecount size, Lisp_Object stream)
 561 {
 562         /* This function can GC */
 563 #ifdef ERROR_CHECK_BUFPOS
 564         assert(size >= 0);
 565 #endif
 566         output_string(stream, str, Qnil, 0, size);
 567 }
 568
 569
 570 void write_hex_ptr(void* value, Lisp_Object stream)
 571 {
 572         char buf[sizeof(value)*2+1];
 573         int n = snprintf(buf,sizeof(buf),"0x%p",value);
 574         assert(n>=0 && (size_t)n<sizeof(buf));
 575         write_c_string(buf,stream);
 576 }
 577
 578 void write_c_string(const char *str, Lisp_Object stream)
 579 {
 580         /* This function can GC */
 581         write_string_1((const Bufbyte *)str, strlen(str), stream);
 582 }
 583
 584 \f
 585 DEFUN("write-char", Fwrite_char, 1, 2, 0,       /*
 586 Output character CHARACTER to stream STREAM.
 587 STREAM defaults to the value of `standard-output' (which see).
 588 */
 589       (character, stream))
 590 {
 591         /* This function can GC */
 592         Bufbyte str[MAX_EMCHAR_LEN];
 593         Bytecount len;
 594
 595         CHECK_CHAR_COERCE_INT(character);
 596         len = set_charptr_emchar(str, XCHAR(character));
 597         output_string(canonicalize_printcharfun(stream), str, Qnil, 0, len);
 598         return character;
 599 }
 600
 601 void temp_output_buffer_setup(Lisp_Object bufname)
 602 {
 603         /* This function can GC */
 604         struct buffer *old = current_buffer;
 605         Lisp_Object buf;
 606
 607 #ifdef I18N3
 608         /* #### This function should accept a Lisp_Object instead of a char *,
 609            so that proper translation on the buffer name can occur. */
 610 #endif
 611
 612         Fset_buffer(Fget_buffer_create(bufname));
 613
 614         current_buffer->read_only = Qnil;
 615         Ferase_buffer(Qnil);
 616
 617         XSETBUFFER(buf, current_buffer);
 618         specbind(Qstandard_output, buf);
 619
 620         set_buffer_internal(old);
 621 }
 622
 623 Lisp_Object
 624 internal_with_output_to_temp_buffer(Lisp_Object bufname,
 625                                     Lisp_Object(*function) (Lisp_Object arg),
 626                                     Lisp_Object arg, Lisp_Object same_frame)
 627 {
 628         int speccount = specpdl_depth();
 629         struct gcpro gcpro1, gcpro2, gcpro3;
 630         Lisp_Object buf = Qnil;
 631
 632         GCPRO3(buf, arg, same_frame);
 633
 634         temp_output_buffer_setup(bufname);
 635         buf = Vstandard_output;
 636
 637         arg = (*function) (arg);
 638
 639         temp_output_buffer_show(buf, same_frame);
 640         UNGCPRO;
 641
 642         return unbind_to(speccount, arg);
 643 }
 644
 645 DEFUN("with-output-to-temp-buffer", Fwith_output_to_temp_buffer, 1, UNEVALLED, 0,       /*
 646 Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
 647 The buffer is cleared out initially, and marked as unmodified when done.
 648 All output done by BODY is inserted in that buffer by default.
 649 The buffer is displayed in another window, but not selected.
 650 The value of the last form in BODY is returned.
 651 If BODY does not finish normally, the buffer BUFNAME is not displayed.
 652
 653 If variable `temp-buffer-show-function' is non-nil, call it at the end
 654 to get the buffer displayed.  It gets one argument, the buffer to display.
 655 */
 656       (args))
 657 {
 658         /* This function can GC */
 659         Lisp_Object name = Qnil;
 660         int speccount = specpdl_depth();
 661         struct gcpro gcpro1, gcpro2;
 662         Lisp_Object val = Qnil;
 663
 664 #ifdef I18N3
 665         /* #### should set the buffer to be translating.  See print_internal(). */
 666 #endif
 667
 668         GCPRO2(name, val);
 669         name = Feval(XCAR(args));
 670
 671         CHECK_STRING(name);
 672
 673         temp_output_buffer_setup(name);
 674         UNGCPRO;
 675
 676         val = Fprogn(XCDR(args));
 677
 678         temp_output_buffer_show(Vstandard_output, Qnil);
 679
 680         return unbind_to(speccount, val);
 681 }
 682 \f
 683 DEFUN("terpri", Fterpri, 0, 1, 0,       /*
 684 Output a newline to STREAM.
 685 If STREAM is omitted or nil, the value of `standard-output' is used.
 686 */
 687       (stream))
 688 {
 689         /* This function can GC */
 690         write_char_internal("\n", canonicalize_printcharfun(stream));
 691         return Qt;
 692 }
 693
 694 DEFUN("prin1", Fprin1, 1, 2, 0, /*
 695 Output the printed representation of OBJECT, any Lisp object.
 696 Quoting characters are printed when needed to make output that `read'
 697 can handle, whenever this is possible.
 698 Output stream is STREAM, or value of `standard-output' (which see).
 699 */
 700       (object, stream))
 701 {
 702         /* This function can GC */
 703         Lisp_Object frame = Qnil;
 704         struct gcpro gcpro1, gcpro2;
 705         GCPRO2(object, stream);
 706
 707         print_depth = 0;
 708         stream = print_prepare(stream, &frame);
 709         print_internal(object, stream, 1);
 710         print_finish(stream, frame);
 711
 712         UNGCPRO;
 713         return object;
 714 }
 715
 716 DEFUN("prin1-to-string", Fprin1_to_string, 1, 2, 0,     /*
 717 Return a string containing the printed representation of OBJECT,
 718 any Lisp object.  Quoting characters are used when needed to make output
 719 that `read' can handle, whenever this is possible, unless the optional
 720 second argument NOESCAPE is non-nil.
 721 */
 722       (object, noescape))
 723 {
 724         /* This function can GC */
 725         Lisp_Object result = Qnil;
 726         Lisp_Object stream = make_resizing_buffer_output_stream();
 727         Lstream *str = XLSTREAM(stream);
 728         /* gcpro OBJECT in case a caller forgot to do so */
 729         struct gcpro gcpro1, gcpro2, gcpro3;
 730         GCPRO3(object, stream, result);
 731
 732         print_depth = 0;
 733         RESET_PRINT_GENSYM;
 734         print_internal(object, stream, NILP(noescape));
 735         RESET_PRINT_GENSYM;
 736         Lstream_flush(str);
 737         UNGCPRO;
 738         result = make_string(resizing_buffer_stream_ptr(str),
 739                              Lstream_byte_count(str));
 740         Lstream_delete(str);
 741         return result;
 742 }
 743
 744 DEFUN("princ", Fprinc, 1, 2, 0, /*
 745 Output the printed representation of OBJECT, any Lisp object.
 746 No quoting characters are used; no delimiters are printed around
 747 the contents of strings.
 748 Output stream is STREAM, or value of `standard-output' (which see).
 749 */
 750       (object, stream))
 751 {
 752         /* This function can GC */
 753         Lisp_Object frame = Qnil;
 754         struct gcpro gcpro1, gcpro2;
 755
 756         GCPRO2(object, stream);
 757         stream = print_prepare(stream, &frame);
 758         print_depth = 0;
 759         print_internal(object, stream, 0);
 760         print_finish(stream, frame);
 761         UNGCPRO;
 762         return object;
 763 }
 764
 765 DEFUN("print", Fprint, 1, 2, 0, /*
 766 Output the printed representation of OBJECT, with newlines around it.
 767 Quoting characters are printed when needed to make output that `read'
 768 can handle, whenever this is possible.
 769 Output stream is STREAM, or value of `standard-output' (which see).
 770 */
 771       (object, stream))
 772 {
 773         /* This function can GC */
 774         Lisp_Object frame = Qnil;
 775         struct gcpro gcpro1, gcpro2;
 776
 777         GCPRO2(object, stream);
 778         stream = print_prepare(stream, &frame);
 779         print_depth = 0;
 780         write_char_internal("\n", stream);
 781         print_internal(object, stream, 1);
 782         write_char_internal("\n", stream);
 783         print_finish(stream, frame);
 784         UNGCPRO;
 785         return object;
 786 }
 787 \f
 788 /* Print an error message for the error DATA to STREAM.  This is a
 789    complete implementation of `display-error', which used to be in
 790    Lisp (see prim/cmdloop.el).  It was ported to C so it can be used
 791    efficiently by Ferror_message_string.  Fdisplay_error and
 792    Ferror_message_string are trivial wrappers around this function.
 793
 794    STREAM should be the result of canonicalize_printcharfun().  */
 795 static void
 796 print_error_message(Lisp_Object error_object, Lisp_Object stream)
 797 {
 798         /* This function can GC */
 799         Lisp_Object type = Fcar_safe(error_object);
 800         Lisp_Object method = Qnil;
 801         Lisp_Object tail;
 802
 803         /* No need to GCPRO anything under the assumption that ERROR_OBJECT
 804            is GCPRO'd.  */
 805
 806         if (!(CONSP(error_object) && SYMBOLP(type))) {
 807                 Lisp_Object foo = Fget(type, Qerror_conditions, Qnil);
 808                 if (CONSP(foo)) {
 809                         goto error_throw;
 810                 }
 811         }
 812
 813         tail = XCDR(error_object);
 814         while (!NILP(tail)) {
 815                 if (CONSP(tail))
 816                         tail = XCDR(tail);
 817                 else
 818                         goto error_throw;
 819         }
 820         tail = Fget(type, Qerror_conditions, Qnil);
 821         while (!NILP(tail)) {
 822                 if (!(CONSP(tail) && SYMBOLP(XCAR(tail))))
 823                         goto error_throw;
 824                 else if (!NILP(Fget(XCAR(tail), Qdisplay_error, Qnil))) {
 825                         method = Fget(XCAR(tail), Qdisplay_error, Qnil);
 826                         goto error_throw;
 827                 } else
 828                         tail = XCDR(tail);
 829         }
 830         /* Default method */
 831         {
 832                 int first = 1;
 833                 int speccount = specpdl_depth();
 834                 Lisp_Object frame = Qnil;
 835                 struct gcpro gcpro1;
 836                 GCPRO1(stream);
 837
 838                 specbind(Qprint_message_label, Qerror);
 839                 stream = print_prepare(stream, &frame);
 840
 841                 tail = Fcdr(error_object);
 842                 if (EQ(type, Qerror)) {
 843                         print_internal(Fcar(tail), stream, 0);
 844                         tail = Fcdr(tail);
 845                 } else {
 846                         Lisp_Object errmsg = Fget(type, Qerror_message, Qnil);
 847                         if (NILP(errmsg))
 848                                 print_internal(type, stream, 0);
 849                         else
 850                                 print_internal(LISP_GETTEXT(errmsg), stream, 0);
 851                 }
 852                 while (!NILP(tail)) {
 853                         write_c_string(first ? ": " : ", ", stream);
 854                         print_internal(Fcar(tail), stream, 1);
 855                         tail = Fcdr(tail);
 856                         first = 0;
 857                 }
 858                 print_finish(stream, frame);
 859                 UNGCPRO;
 860                 unbind_to(speccount, Qnil);
 861                 return;
 862                 /* not reached */
 863         }
 864
 865 error_throw:
 866         if (NILP(method)) {
 867                 write_c_string(GETTEXT("Peculiar error "), stream);
 868                 print_internal(error_object, stream, 1);
 869                 return;
 870         } else {
 871                 call2(method, error_object, stream);
 872         }
 873 }
 874
 875 DEFUN("error-message-string", Ferror_message_string, 1, 1, 0,   /*
 876 Convert ERROR-OBJECT to an error message, and return it.
 877
 878 The format of ERROR-OBJECT should be (ERROR-SYMBOL . DATA).  The
 879 message is equivalent to the one that would be issued by
 880 `display-error' with the same argument.
 881 */
 882       (error_object))
 883 {
 884         /* This function can GC */
 885         Lisp_Object result = Qnil;
 886         Lisp_Object stream = make_resizing_buffer_output_stream();
 887         struct gcpro gcpro1;
 888         GCPRO1(stream);
 889
 890         print_error_message(error_object, stream);
 891         Lstream_flush(XLSTREAM(stream));
 892         result = make_string(resizing_buffer_stream_ptr(XLSTREAM(stream)),
 893                              Lstream_byte_count(XLSTREAM(stream)));
 894         Lstream_delete(XLSTREAM(stream));
 895
 896         UNGCPRO;
 897         return result;
 898 }
 899
 900 DEFUN("display-error", Fdisplay_error, 2, 2, 0, /*
 901 Display ERROR-OBJECT on STREAM in a user-friendly way.
 902 */
 903       (error_object, stream))
 904 {
 905         /* This function can GC */
 906         print_error_message(error_object, canonicalize_printcharfun(stream));
 907         return Qnil;
 908 }
 909 \f
 910 #ifdef HAVE_FPFLOAT
 911
 912 Lisp_Object Vfloat_output_format;
 913
 914 /*
 915  * This buffer should be at least as large as the max string size of the
 916  * largest float, printed in the biggest notation.  This is undoubtedly
 917  * 20d float_output_format, with the negative of the C-constant "HUGE"
 918  * from <math.h>.
 919  *
 920  * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
 921  *
 922  * I assume that IEEE-754 format numbers can take 329 bytes for the worst
 923  * case of -1e307 in 20d float_output_format. What is one to do (short of
 924  * re-writing _doprnt to be more sane)?
 925  *                      -wsr
 926  */
 927 void float_to_string(char *buf, fpfloat data, int maxlen)
 928 {
 929         Bufbyte *cp, c;
 930         int width, sz;
 931
 932         if (NILP(Vfloat_output_format) || !STRINGP(Vfloat_output_format)) {
 933         lose:
 934 #if fpfloat_double_p
 935                 sz = snprintf(buf, maxlen, "%.16g", data);
 936 #elif fpfloat_long_double_p
 937                 sz = snprintf(buf, maxlen, "%.16Lg", data);
 938 #endif
 939                 assert(sz>=0 && sz<maxlen);
 940         } else {                        /* oink oink */
 941
 942                 /* Check that the spec we have is fully valid.
 943                    This means not only valid for printf,
 944                    but meant for floats, and reasonable.  */
 945                 cp = XSTRING_DATA(Vfloat_output_format);
 946
 947                 if (cp[0] != '%')
 948                         goto lose;
 949                 if (cp[1] != '.')
 950                         goto lose;
 951
 952                 cp += 2;
 953                 for (width = 0; (c = *cp, isdigit(c)); cp++) {
 954                         width *= 10;
 955                         width += c - '0';
 956                 }
 957
 958                 if (*cp != 'e' && *cp != 'f' && *cp != 'g' && *cp != 'E'
 959                     && *cp != 'G')
 960                         goto lose;
 961
 962                 if (width < (int)(*cp != 'e' && *cp != 'E') || width > DBL_DIG)
 963                         goto lose;
 964
 965                 if (cp[1] != 0)
 966                         goto lose;
 967
 968                 sz = snprintf(buf, maxlen,
 969                               (char *)XSTRING_DATA(Vfloat_output_format), data);
 970                 assert(sz>=0 && sz < maxlen);
 971         }
 972
 973         /* added by jwz: don't allow "1.0" to print as "1"; that destroys
 974            the read-equivalence of lisp objects.  (* x 1) and (* x 1.0) do
 975            not do the same thing, so it's important that the printed
 976            representation of that form not be corrupted by the printer.
 977          */
 978         {
 979                 Bufbyte *s = (Bufbyte *) buf;   /* don't use signed chars here!
 980                                                    isdigit() can't hack them! */
 981                 if (*s == '-') {
 982                         s++;
 983                         maxlen--;
 984                         assert(maxlen>0);
 985                 }
 986                 for (; *s; s++)
 987                         /* if there's a non-digit, then there is a decimal point, or
 988                            it's in exponential notation, both of which are ok. */
 989                         if (!isdigit(*s))
 990                                 goto DONE_LABEL;
 991                 /* otherwise, we need to hack it. */
 992                 maxlen-=2;
 993                 assert(maxlen>0);
 994                 *s++ = '.';
 995                 *s++ = '0';
 996                 *s = 0;
 997         }
 998       DONE_LABEL:
 999
1000         /* Some machines print "0.4" as ".4".  I don't like that. */
1001         if (buf[0] == '.' || (buf[0] == '-' && buf[1] == '.')) {
1002                 assert(maxlen>0);
1003                 int i;
1004                 for (i = strlen(buf) + 1; i >= 0; i--)
1005                         buf[i + 1] = buf[i];
1006                 buf[(buf[0] == '-' ? 1 : 0)] = '0';
1007         }
1008 }
1009 #endif                          /* HAVE_FPFLOAT */
1010
1011 /* Print NUMBER to BUFFER.
1012    This is equivalent to snprintf (buffer, maxlen, "%ld", number), only much faster.
1013
1014    BUFFER should accept 24 bytes.  This should suffice for the longest
1015    numbers on 64-bit machines, including the `-' sign and the trailing
1016    '\0'.  Returns a pointer to the trailing '\0'. */
1017 char *long_to_string(char *buffer, long number, int maxlen)
1018 {
1019 #if (SIZEOF_LONG != 4) && (SIZEOF_LONG != 8)
1020         /* Huh? */
1021         int sz = snprintf(buffer, maxlen, "%ld", number);
1022         assert(sz>=0 && sz < maxlen);
1023         return buffer + strlen(buffer);
1024 #else                           /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
1025         char *p = buffer;
1026         int force = 0;
1027
1028         if (number < 0) {
1029                 *p++ = '-';
1030                 number = -number;
1031         }
1032 #define FROB(figure) \
1033         do {                                                            \
1034                 if (force || number >= figure) {                        \
1035                         *p++ = number / figure + '0';                   \
1036                         number %= figure;                               \
1037                         force = 1;                                      \
1038                         --maxlen;                                       \
1039                         assert(maxlen>0);                               \
1040                 }                                                       \
1041         } while (0)
1042 #if SIZEOF_LONG == 8
1043         FROB(1000000000000000000L);
1044         FROB(100000000000000000L);
1045         FROB(10000000000000000L);
1046         FROB(1000000000000000L);
1047         FROB(100000000000000L);
1048         FROB(10000000000000L);
1049         FROB(1000000000000L);
1050         FROB(100000000000L);
1051         FROB(10000000000L);
1052 #endif                          /* SIZEOF_LONG == 8 */
1053         FROB(1000000000);
1054         FROB(100000000);
1055         FROB(10000000);
1056         FROB(1000000);
1057         FROB(100000);
1058         FROB(10000);
1059         FROB(1000);
1060         FROB(100);
1061         FROB(10);
1062 #undef FROB
1063         *p++ = number + '0';
1064         *p = '\0';
1065         return p;
1066 #endif                          /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
1067 }
1068 \f
1069 static void
1070 print_vector_internal(const char *start, const char *end,
1071                       Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1072 {
1073         /* This function can GC */
1074         int i;
1075         int len = XVECTOR_LENGTH(obj);
1076         int last = len;
1077         struct gcpro gcpro1, gcpro2;
1078         GCPRO2(obj, printcharfun);
1079
1080         if (INTP(Vprint_length)) {
1081                 int max = XINT(Vprint_length);
1082                 if (max < len)
1083                         last = max;
1084         }
1085
1086         write_c_string(start, printcharfun);
1087         for (i = 0; i < last; i++) {
1088                 Lisp_Object elt = XVECTOR_DATA(obj)[i];
1089                 if (i != 0)
1090                         write_char_internal(" ", printcharfun);
1091                 print_internal(elt, printcharfun, escapeflag);
1092         }
1093         UNGCPRO;
1094         if (last != len)
1095                 write_c_string(" ...", printcharfun);
1096         write_c_string(end, printcharfun);
1097 }
1098
1099 void print_cons(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1100 {
1101         /* This function can GC */
1102         struct gcpro gcpro1, gcpro2;
1103
1104         /* If print_readably is on, print (quote -foo-) as '-foo-
1105            (Yeah, this should really be what print-pretty does, but we
1106            don't have the rest of a pretty printer, and this actually
1107            has non-negligible impact on size/speed of .elc files.)
1108          */
1109         if (print_readably &&
1110             EQ(XCAR(obj), Qquote) &&
1111             CONSP(XCDR(obj)) && NILP(XCDR(XCDR(obj)))) {
1112                 obj = XCAR(XCDR(obj));
1113                 GCPRO2(obj, printcharfun);
1114                 write_char_internal("\'", printcharfun);
1115                 UNGCPRO;
1116                 print_internal(obj, printcharfun, escapeflag);
1117                 return;
1118         }
1119
1120         GCPRO2(obj, printcharfun);
1121         write_char_internal("(", printcharfun);
1122
1123         {
1124                 int len;
1125                 int max = INTP(Vprint_length) ? XINT(Vprint_length) : INT_MAX;
1126                 Lisp_Object tortoise;
1127                 /* Use tortoise/hare to make sure circular lists don't infloop */
1128
1129                 for (tortoise = obj, len = 0;
1130                      CONSP(obj); obj = XCDR(obj), len++) {
1131                         if (len > 0)
1132                                 write_char_internal(" ", printcharfun);
1133                         if (EQ(obj, tortoise) && len > 0) {
1134                                 if (print_readably)
1135                                         error
1136                                             ("printing unreadable circular list");
1137                                 else
1138                                         write_c_string("... <circular list>",
1139                                                        printcharfun);
1140                                 break;
1141                         }
1142                         if (len & 1)
1143                                 tortoise = XCDR(tortoise);
1144                         if (len > max) {
1145                                 write_c_string("...", printcharfun);
1146                                 break;
1147                         }
1148                         print_internal(XCAR(obj), printcharfun, escapeflag);
1149                 }
1150         }
1151         if (!LISTP(obj)) {
1152                 write_c_string(" . ", printcharfun);
1153                 print_internal(obj, printcharfun, escapeflag);
1154         }
1155         UNGCPRO;
1156
1157         write_char_internal(")", printcharfun);
1158         return;
1159 }
1160
1161 void print_vector(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1162 {
1163         print_vector_internal("[", "]", obj, printcharfun, escapeflag);
1164 }
1165
1166 void print_string(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1167 {
1168         Lisp_String *s = XSTRING(obj);
1169         /* We distinguish between Bytecounts and Charcounts, to make
1170            Vprint_string_length work correctly under Mule.  */
1171         Charcount size = string_char_length(s);
1172         Charcount max = size;
1173         Bytecount bcmax = string_length(s);
1174         struct gcpro gcpro1, gcpro2;
1175         GCPRO2(obj, printcharfun);
1176
1177         if (INTP(Vprint_string_length) && XINT(Vprint_string_length) < max) {
1178                 max = XINT(Vprint_string_length);
1179                 bcmax = charcount_to_bytecount(string_data(s), max);
1180         }
1181         if (max < 0) {
1182                 max = 0;
1183                 bcmax = 0;
1184         }
1185
1186         if (!escapeflag) {
1187                 /* This deals with GC-relocation and Mule. */
1188                 output_string(printcharfun, 0, obj, 0, bcmax);
1189                 if (max < size)
1190                         write_c_string(" ...", printcharfun);
1191         } else {
1192                 Bytecount i, last = 0;
1193
1194                 write_char_internal("\"", printcharfun);
1195                 for (i = 0; i < bcmax; i++) {
1196                         Bufbyte ch = string_byte(s, i);
1197                         if (ch == '\"' || ch == '\\'
1198                             || (ch == '\n' && print_escape_newlines)) {
1199                                 if (i > last) {
1200                                         output_string(printcharfun, 0, obj,
1201                                                       last, i - last);
1202                                 }
1203                                 if (ch == '\n') {
1204                                         write_c_string("\\n", printcharfun);
1205                                 } else {
1206                                         write_char_internal("\\", printcharfun);
1207                                         /* This is correct for Mule because the
1208                                            character is either \ or " */
1209                                         write_char_internal(string_data(s) + i,
1210                                                             printcharfun);
1211                                 }
1212                                 last = i + 1;
1213                         }
1214                 }
1215                 if (bcmax > last) {
1216                         output_string(printcharfun, 0, obj, last, bcmax - last);
1217                 }
1218                 if (max < size)
1219                         write_c_string(" ...", printcharfun);
1220                 write_char_internal("\"", printcharfun);
1221         }
1222         UNGCPRO;
1223 }
1224
1225 static void
1226 default_object_printer(Lisp_Object obj, Lisp_Object printcharfun,
1227                        int escapeflag)
1228 {
1229         struct lcrecord_header *header = (struct lcrecord_header *)XPNTR(obj);
1230
1231         if (print_readably)
1232                 error("printing unreadable object #<%s 0x%x>",
1233                       LHEADER_IMPLEMENTATION(&header->lheader)->name,
1234                       header->uid);
1235
1236         write_fmt_string(printcharfun, "#<%s 0x%x>",
1237                          LHEADER_IMPLEMENTATION(&header->lheader)->name, header->uid);
1238 }
1239
1240 void
1241 internal_object_printer(Lisp_Object obj, Lisp_Object printcharfun,
1242                         int escapeflag)
1243 {
1244         write_fmt_string(printcharfun, "#<INTERNAL OBJECT (SXEmacs bug?) (%s) 0x%lx>",
1245                          XRECORD_LHEADER_IMPLEMENTATION(obj)->name,
1246                          (unsigned long)XPNTR(obj));
1247 }
1248
1249 enum printing_badness {
1250         BADNESS_INTEGER_OBJECT,
1251         BADNESS_POINTER_OBJECT,
1252         BADNESS_NO_TYPE
1253 };
1254
1255 static void
1256 printing_major_badness(Lisp_Object printcharfun,
1257                        Char_ASCII * badness_string, int type, void *val,
1258                        enum printing_badness badness)
1259 {
1260         char buf[666];
1261         ssize_t len;
1262
1263         switch (badness) {
1264         case BADNESS_INTEGER_OBJECT:
1265                 len = snprintf(buf, sizeof(buf), "%s %d object %ld", badness_string, type,
1266                                (EMACS_INT) val);
1267                 break;
1268
1269         case BADNESS_POINTER_OBJECT:
1270                 len = snprintf(buf, sizeof(buf), "%s %d object %p", badness_string, type, val);
1271                 break;
1272
1273         case BADNESS_NO_TYPE:
1274                 len = snprintf(buf, sizeof(buf), "%s object %p", badness_string, val);
1275                 break;
1276         default:
1277                 len = snprintf(buf, sizeof(buf), "%s unknown badness %d",
1278                                badness_string, badness);
1279                 break;
1280         }
1281         assert(len >= 0 && (size_t)len < sizeof(buf));
1282
1283         /* Don't abort or signal if called from debug_print() or already
1284            crashing */
1285         if (!inhibit_non_essential_printing_operations) {
1286 #ifdef ERROR_CHECK_TYPES
1287                 abort();
1288 #else                           /* not ERROR_CHECK_TYPES */
1289                 if (print_readably)
1290                         type_error(Qinternal_error, "printing %s", buf);
1291 #endif                          /* not ERROR_CHECK_TYPES */
1292         }
1293         write_fmt_string(printcharfun,
1294                          "#<EMACS BUG: %s Save your buffers immediately and "
1295                          "please report this bug>", buf);
1296 }
1297
1298 void
1299 print_internal(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1300 {
1301         /* This function can GC */
1302         /* defined in emacs.c */
1303         extern int inhibit_autoloads, nodumpfile;
1304
1305         QUIT;
1306
1307         /* Emacs won't print while GCing, but an external debugger might */
1308         if (gc_in_progress)
1309                 return;
1310
1311 #ifdef I18N3
1312         /* #### Both input and output streams should have a flag associated
1313            with them indicating whether output to that stream, or strings
1314            read from the stream, get translated using Fgettext().  Such a
1315            stream is called a "translating stream".  For the minibuffer and
1316            external-debugging-output this is always true on output, and
1317            with-output-to-temp-buffer sets the flag to true for the buffer
1318            it creates.  This flag should also be user-settable.  Perhaps it
1319            should be split up into two flags, one for input and one for
1320            output. */
1321 #endif
1322
1323         /* Try out custom printing */
1324         if (UNLIKELY(!(bool)inhibit_autoloads && !(bool)nodumpfile) &&
1325             !EQ(Qnil, Vcustom_object_printer) &&
1326             !EQ(Qnil, apply1(Vcustom_object_printer,
1327                              Fcons(obj, Fcons(printcharfun, Qnil))))) {
1328                 return;
1329         }
1330
1331         /* Detect circularities and truncate them.
1332            No need to offer any alternative--this is better than an error.  */
1333         if (CONSP(obj) || VECTORP(obj) || COMPILED_FUNCTIONP(obj)) {
1334                 int i;
1335                 for (i = 0; i < print_depth; i++)
1336                         if (EQ(obj, being_printed[i])) {
1337                                 char buf[32];
1338                                 *buf = '#';
1339                                 long_to_string(buf + 1, i, sizeof(buf)-1);
1340                                 write_c_string(buf, printcharfun);
1341                                 return;
1342                         }
1343         }
1344
1345         being_printed[print_depth] = obj;
1346         print_depth++;
1347
1348         if (print_depth > PRINT_CIRCLE) {
1349                 error("Apparently circular structure being printed");
1350         }
1351
1352         switch (XTYPE(obj)) {
1353         case Lisp_Type_Int_Even:
1354         case Lisp_Type_Int_Odd: {
1355                 /* ASCII Decimal representation uses 2.4 times as many bits as
1356                    machine binary.  */
1357                 char buf[3 * sizeof(EMACS_INT) + 5];
1358                 long_to_string(buf, XINT(obj),sizeof(buf));
1359                 write_c_string(buf, printcharfun);
1360                 break;
1361         }
1362
1363         case Lisp_Type_Char: {
1364                 /* God intended that this be #\..., you know. */
1365                 char buf[16];
1366                 memset(buf, 0, sizeof(buf));
1367                 Emchar ch = XCHAR(obj);
1368                 char *p = buf;
1369                 *p++ = '?';
1370                 if (ch < 32) {
1371                         *p++ = '\\';
1372                         switch (ch) {
1373                         case '\t':
1374                                 *p++ = 't';
1375                                 break;
1376                         case '\n':
1377                                 *p++ = 'n';
1378                                 break;
1379                         case '\r':
1380                                 *p++ = 'r';
1381                                 break;
1382                         default:
1383                                 *p++ = '^';
1384                                 *p++ = ch + 64;
1385                                 if ((ch + 64) == '\\')
1386                                         *p++ = '\\';
1387                                 break;
1388                         }
1389                 } else if (ch < 127) {
1390                         /* syntactically special characters should be
1391                            escaped. */
1392                         switch (ch) {
1393                         case ' ':
1394                         case '"':
1395                         case '#':
1396                         case '\'':
1397                         case '(':
1398                         case ')':
1399                         case ',':
1400                         case '.':
1401                         case ';':
1402                         case '?':
1403                         case '[':
1404                         case '\\':
1405                         case ']':
1406                         case '`':
1407                                 *p++ = '\\';
1408                         default:
1409                                 break;
1410                         }
1411                         *p++ = ch;
1412                 } else if (ch == 127) {
1413                         *p++ = '\\', *p++ = '^', *p++ = '?';
1414                 } else if (ch < 160) {
1415                         *p++ = '\\', *p++ = '^';
1416                         p += set_charptr_emchar((Bufbyte *) p, ch + 64);
1417                 } else {
1418                         p += set_charptr_emchar((Bufbyte *) p, ch);
1419                 }
1420
1421                 output_string(printcharfun, (Bufbyte *) buf, Qnil, 0,
1422                               p - buf);
1423
1424                 break;
1425         }
1426
1427         case Lisp_Type_Record: {
1428                 struct lrecord_header *lheader = XRECORD_LHEADER(obj);
1429
1430                 /* Try to check for various sorts of bogus pointers if we're in
1431                    a situation where it may be likely -- i.e. called from
1432                    debug_print() or we're already crashing.  In such cases,
1433                    (further) crashing is counterproductive. */
1434
1435                 if (inhibit_non_essential_printing_operations &&
1436                     !debug_can_access_memory(lheader, sizeof(*lheader))) {
1437                         write_fmt_string(printcharfun,
1438                                          "#<EMACS BUG: BAD MEMORY ACCESS %p>",
1439                                          lheader);
1440                         break;
1441                 }
1442
1443                 if (CONSP(obj) || VECTORP(obj)) {
1444                         /* If deeper than spec'd depth, print placeholder.  */
1445                         if (INTP(Vprint_level)
1446                             && print_depth > XINT(Vprint_level)) {
1447                                 write_c_string("...", printcharfun);
1448                                 break;
1449                         }
1450                 }
1451
1452                 if (lheader->type == lrecord_type_free) {
1453                         printing_major_badness(printcharfun,
1454                                                "freed lrecord", 0,
1455                                                lheader,
1456                                                BADNESS_NO_TYPE);
1457                         break;
1458                 } else if (lheader->type == lrecord_type_undefined) {
1459                         printing_major_badness(printcharfun,
1460                                                "lrecord_type_undefined",
1461                                                0, lheader,
1462                                                BADNESS_NO_TYPE);
1463                         break;
1464                 } else if (lheader->type >= lrecord_type_count) {
1465                         printing_major_badness(printcharfun,
1466                                                "illegal lrecord type",
1467                                                (int)(lheader->type),
1468                                                lheader,
1469                                                BADNESS_POINTER_OBJECT);
1470                         break;
1471                 }
1472
1473                 /* Further checks for bad memory in critical situations.  We
1474                    don't normally do these because they may be expensive or
1475                    weird (e.g. under Unix we typically have to set a SIGSEGV
1476                    handler and try to trigger a seg fault). */
1477
1478                 if (inhibit_non_essential_printing_operations) {
1479                         const struct lrecord_implementation *imp =
1480                                 LHEADER_IMPLEMENTATION(lheader);
1481
1482                         if (!debug_can_access_memory
1483                             (lheader, imp->size_in_bytes_method ?
1484                              imp->size_in_bytes_method(lheader) :
1485                              imp->static_size)) {
1486                                 write_fmt_string(
1487                                         printcharfun,
1488                                         "#<EMACS BUG: type %s "
1489                                         "BAD MEMORY ACCESS %p>",
1490                                         LHEADER_IMPLEMENTATION
1491                                         (lheader)->name, lheader);
1492                                 break;
1493                         }
1494
1495                         if (STRINGP(obj)) {
1496                                 Lisp_String *l = (Lisp_String *)lheader;
1497                                 if (!debug_can_access_memory(
1498                                             l->data, l->size)) {
1499                                         write_fmt_string(
1500                                                 printcharfun,
1501                                                 "#<EMACS BUG: %p "
1502                                                 "(CAN'T ACCESS STRING "
1503                                                 "DATA %p)>", lheader, l->data);
1504                                         break;
1505                                 }
1506                         }
1507                 }
1508
1509                 if (LHEADER_IMPLEMENTATION(lheader)->printer) {
1510                         ((LHEADER_IMPLEMENTATION(lheader)->printer)
1511                          (obj, printcharfun, escapeflag));
1512                 } else {
1513                         default_object_printer(obj, printcharfun, escapeflag);
1514                 }
1515                 break;
1516         }
1517
1518         default: {
1519                 /* We're in trouble if this happens! */
1520                 printing_major_badness(printcharfun,
1521                                        "illegal data type", XTYPE(obj),
1522                                        LISP_TO_VOID(obj),
1523                                        BADNESS_INTEGER_OBJECT);
1524                 break;
1525         }
1526         }
1527
1528         print_depth--;
1529         return;
1530 }
1531
1532 void print_symbol(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1533 {
1534         /* This function can GC */
1535         /* #### Bug!! (intern "") isn't printed in some distinguished way */
1536         /* ####  (the reader also loses on it) */
1537         Lisp_String *name = symbol_name(XSYMBOL(obj));
1538         Bytecount size = string_length(name);
1539         struct gcpro gcpro1, gcpro2;
1540
1541         if (!escapeflag) {
1542                 /* This deals with GC-relocation */
1543                 Lisp_Object nameobj;
1544                 XSETSTRING(nameobj, name);
1545                 output_string(printcharfun, 0, nameobj, 0, size);
1546                 return;
1547         }
1548         GCPRO2(obj, printcharfun);
1549
1550         /* If we print an uninterned symbol as part of a complex object and
1551            the flag print-gensym is non-nil, prefix it with #n= to read the
1552            object back with the #n# reader syntax later if needed.  */
1553         if (!NILP(Vprint_gensym)
1554             /* #### Test whether this produces a noticeable slow-down for
1555                printing when print-gensym is non-nil.  */
1556             && !EQ(obj, oblookup(Vobarray,
1557                                  string_data(symbol_name(XSYMBOL(obj))),
1558                                  string_length(symbol_name(XSYMBOL(obj)))))) {
1559                 if (print_depth > 1) {
1560                         Lisp_Object tem = Fassq(obj, Vprint_gensym_alist);
1561                         if (CONSP(tem)) {
1562                                 write_char_internal("#", printcharfun);
1563                                 print_internal(XCDR(tem), printcharfun,
1564                                                escapeflag);
1565                                 write_char_internal("#", printcharfun);
1566                                 UNGCPRO;
1567                                 return;
1568                         } else {
1569                                 if (CONSP(Vprint_gensym_alist)) {
1570                                         /* Vprint_gensym_alist is exposed to Lisp, so we
1571                                            have to be careful.  */
1572                                         CHECK_CONS(XCAR(Vprint_gensym_alist));
1573                                         CHECK_INT(XCDR
1574                                                   (XCAR(Vprint_gensym_alist)));
1575                                         XSETINT(tem,
1576                                                 XINT(XCDR
1577                                                      (XCAR
1578                                                       (Vprint_gensym_alist))) +
1579                                                 1);
1580                                 } else
1581                                         XSETINT(tem, 1);
1582                                 Vprint_gensym_alist =
1583                                     Fcons(Fcons(obj, tem), Vprint_gensym_alist);
1584
1585                                 write_char_internal("#", printcharfun);
1586                                 print_internal(tem, printcharfun, escapeflag);
1587                                 write_char_internal("=", printcharfun);
1588                         }
1589                 }
1590                 write_c_string("#:", printcharfun);
1591         }
1592
1593         /* Does it look like an integer or a float? */
1594         {
1595                 Bufbyte *data = string_data(name);
1596                 Bytecount confusing = 0;
1597
1598                 if (size == 0)
1599                         goto not_yet_confused;  /* Really confusing */
1600                 else if (isdigit(data[0]))
1601                         confusing = 0;
1602                 else if (size == 1)
1603                         goto not_yet_confused;
1604                 else if (data[0] == '-' || data[0] == '+')
1605                         confusing = 1;
1606                 else
1607                         goto not_yet_confused;
1608
1609                 for (; confusing < size; confusing++) {
1610                         if (!isdigit(data[confusing])) {
1611                                 confusing = 0;
1612                                 break;
1613                         }
1614                 }
1615               not_yet_confused:
1616
1617 #ifdef HAVE_FPFLOAT
1618                 if (!confusing)
1619                         /* #### Ugh, this is needlessly complex and slow for what we
1620                            need here.  It might be a good idea to copy equivalent code
1621                            from FSF.  --hniksic */
1622                         confusing = isfloat_string((char *)data);
1623 #endif
1624                 if (confusing)
1625                         write_char_internal("\\", printcharfun);
1626         }
1627
1628         {
1629                 Lisp_Object nameobj;
1630                 Bytecount i;
1631                 Bytecount last = 0;
1632
1633                 XSETSTRING(nameobj, name);
1634                 for (i = 0; i < size; i++) {
1635                         switch (string_byte(name, i)) {
1636                         case 0:
1637                         case 1:
1638                         case 2:
1639                         case 3:
1640                         case 4:
1641                         case 5:
1642                         case 6:
1643                         case 7:
1644                         case 8:
1645                         case 9:
1646                         case 10:
1647                         case 11:
1648                         case 12:
1649                         case 13:
1650                         case 14:
1651                         case 15:
1652                         case 16:
1653                         case 17:
1654                         case 18:
1655                         case 19:
1656                         case 20:
1657                         case 21:
1658                         case 22:
1659                         case 23:
1660                         case 24:
1661                         case 25:
1662                         case 26:
1663                         case 27:
1664                         case 28:
1665                         case 29:
1666                         case 30:
1667                         case 31:
1668                         case ' ':
1669                         case '\"':
1670                         case '\\':
1671                         case '\'':
1672                         case ';':
1673                         case '#':
1674                         case '(':
1675                         case ')':
1676                         case ',':
1677                         case '.':
1678                         case '`':
1679                         case '[':
1680                         case ']':
1681                         case '?':
1682                                 if (i > last)
1683                                         output_string(printcharfun, 0, nameobj,
1684                                                       last, i - last);
1685                                 write_char_internal("\\", printcharfun);
1686                                 last = i;
1687                         default:
1688                                 break;
1689                         }
1690                 }
1691                 output_string(printcharfun, 0, nameobj, last, size - last);
1692         }
1693         UNGCPRO;
1694 }
1695 \f
1696 /* Useful on systems or in places where writing to stdout is unavailable or
1697    not working. */
1698
1699 static int alternate_do_pointer;
1700 static char alternate_do_string[5000];
1701
1702 DEFUN("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0,       /*
1703 Append CHARACTER to the array `alternate_do_string'.
1704 This can be used in place of `external-debugging-output' as a function
1705 to be passed to `print'.  Before calling `print', set `alternate_do_pointer'
1706 to 0.
1707 */
1708       (character))
1709 {
1710         Bufbyte str[MAX_EMCHAR_LEN];
1711         Bytecount len;
1712         int extlen;
1713         const Extbyte *extptr;
1714
1715         CHECK_CHAR_COERCE_INT(character);
1716         len = set_charptr_emchar(str, XCHAR(character));
1717         TO_EXTERNAL_FORMAT(DATA, (str, len),
1718                            ALLOCA, (extptr, extlen), Qterminal);
1719         memcpy(alternate_do_string + alternate_do_pointer, extptr, extlen);
1720         alternate_do_pointer += extlen;
1721         alternate_do_string[alternate_do_pointer] = 0;
1722         return character;
1723 }
1724
1725 DEFUN("external-debugging-output", Fexternal_debugging_output, 1, 3, 0, /*
1726 Write CHAR-OR-STRING to stderr or stdout.
1727 If optional arg STDOUT-P is non-nil, write to stdout; otherwise, write
1728 to stderr.  You can use this function to write directly to the terminal.
1729 This function can be used as the STREAM argument of Fprint() or the like.
1730
1731 Under MS Windows, this writes output to the console window (which is
1732 created, if necessary), unless SXEmacs is being run noninteractively
1733 \(i.e. using the `-batch' argument).
1734
1735 If you have opened a termscript file (using `open-termscript'), then
1736 the output also will be logged to this file.
1737 */
1738       (char_or_string, stdout_p, device))
1739 {
1740         FILE *file = NULL;
1741         struct console *con = NULL;
1742
1743         if (NILP(device)) {
1744                 if (!NILP(stdout_p))
1745                         file = stdout;
1746                 else
1747                         file = stderr;
1748         } else {
1749                 CHECK_LIVE_DEVICE(device);
1750                 if (!DEVICE_TTY_P(XDEVICE(device)) &&
1751                     !DEVICE_STREAM_P(XDEVICE(device)))
1752                         signal_simple_error("Must be tty or stream device",
1753                                             device);
1754                 con = XCONSOLE(DEVICE_CONSOLE(XDEVICE(device)));
1755                 if (DEVICE_TTY_P(XDEVICE(device))) {
1756                         file = 0;
1757                 } else if (!NILP(stdout_p)) {
1758                         file = CONSOLE_STREAM_DATA(con)->out;
1759                 } else {
1760                         file = CONSOLE_STREAM_DATA(con)->err;
1761                 }
1762         }
1763
1764         if (STRINGP(char_or_string))
1765                 write_string_to_stdio_stream(file, con,
1766                                              XSTRING_DATA(char_or_string),
1767                                              0, XSTRING_LENGTH(char_or_string),
1768                                              Qterminal, 1);
1769         else {
1770                 Bufbyte str[MAX_EMCHAR_LEN];
1771                 Bytecount len;
1772
1773                 CHECK_CHAR_COERCE_INT(char_or_string);
1774                 len = set_charptr_emchar(str, XCHAR(char_or_string));
1775                 write_string_to_stdio_stream(file, con, str, 0, len, Qterminal,
1776                                              1);
1777         }
1778
1779         return char_or_string;
1780 }
1781
1782 DEFUN("open-termscript", Fopen_termscript, 1, 1, "FOpen termscript file: ",     /*
1783 Start writing all terminal output to FILENAME as well as the terminal.
1784 FILENAME = nil means just close any termscript file currently open.
1785 */
1786       (filename))
1787 {
1788         /* This function can GC */
1789         if (termscript != 0) {
1790                 fclose(termscript);
1791                 termscript = 0;
1792         }
1793
1794         if (!NILP(filename)) {
1795                 filename = Fexpand_file_name(filename, Qnil);
1796                 termscript = fopen((char *)XSTRING_DATA(filename), "w");
1797                 if (termscript == NULL)
1798                         report_file_error("Opening termscript",
1799                                           list1(filename));
1800         }
1801         return Qnil;
1802 }
1803
1804 #if 1
1805 /* Debugging kludge -- unbuffered */
1806 static int debug_print_length = 50;
1807 static int debug_print_level = 15;
1808 static int debug_print_readably = -1;
1809
1810 static void debug_print_no_newline(Lisp_Object debug_print_obj)
1811 {
1812         /* This function can GC */
1813         int save_print_readably = print_readably;
1814         int save_print_depth = print_depth;
1815         Lisp_Object save_Vprint_length = Vprint_length;
1816         Lisp_Object save_Vprint_level = Vprint_level;
1817         Lisp_Object save_Vinhibit_quit = Vinhibit_quit;
1818         struct gcpro gcpro1, gcpro2, gcpro3;
1819         GCPRO3(save_Vprint_level, save_Vprint_length, save_Vinhibit_quit);
1820
1821         if (gc_in_progress)
1822                 stderr_out
1823                     ("** gc-in-progress!  Bad idea to print anything! **\n");
1824
1825         print_depth = 0;
1826         print_readably = debug_print_readably != -1 ? debug_print_readably : 0;
1827         print_unbuffered++;
1828         inhibit_non_essential_printing_operations = 1;
1829         /* Could use unwind-protect, but why bother? */
1830         if (debug_print_length > 0)
1831                 Vprint_length = make_int(debug_print_length);
1832         if (debug_print_level > 0)
1833                 Vprint_level = make_int(debug_print_level);
1834
1835         print_internal(debug_print_obj, Qexternal_debugging_output, 1);
1836         alternate_do_pointer = 0;
1837         print_internal(debug_print_obj, Qalternate_debugging_output, 1);
1838
1839         Vinhibit_quit = save_Vinhibit_quit;
1840         Vprint_level = save_Vprint_level;
1841         Vprint_length = save_Vprint_length;
1842         print_depth = save_print_depth;
1843         print_readably = save_print_readably;
1844         inhibit_non_essential_printing_operations = 0;
1845         print_unbuffered--;
1846         UNGCPRO;
1847 }
1848
1849 void debug_print(Lisp_Object debug_print_obj)
1850 {
1851         debug_print_no_newline(debug_print_obj);
1852         stderr_out("\n");
1853 }
1854
1855 /* Debugging kludge -- unbuffered */
1856 /* This function provided for the benefit of the debugger.  */
1857 void debug_backtrace(void)
1858 {
1859         /* This function can GC */
1860         int old_print_readably = print_readably;
1861         int old_print_depth = print_depth;
1862         Lisp_Object old_print_length = Vprint_length;
1863         Lisp_Object old_print_level = Vprint_level;
1864         Lisp_Object old_inhibit_quit = Vinhibit_quit;
1865
1866         struct gcpro gcpro1, gcpro2, gcpro3;
1867         GCPRO3(old_print_level, old_print_length, old_inhibit_quit);
1868
1869         if (gc_in_progress)
1870                 stderr_out
1871                     ("** gc-in-progress!  Bad idea to print anything! **\n");
1872
1873         print_depth = 0;
1874         print_readably = 0;
1875         print_unbuffered++;
1876         inhibit_non_essential_printing_operations = 1;
1877         /* Could use unwind-protect, but why bother? */
1878         if (debug_print_length > 0)
1879                 Vprint_length = make_int(debug_print_length);
1880         if (debug_print_level > 0)
1881                 Vprint_level = make_int(debug_print_level);
1882
1883         Fbacktrace(Qexternal_debugging_output, Qt);
1884         stderr_out("\n");
1885
1886         Vinhibit_quit = old_inhibit_quit;
1887         Vprint_level = old_print_level;
1888         Vprint_length = old_print_length;
1889         print_depth = old_print_depth;
1890         print_readably = old_print_readably;
1891         inhibit_non_essential_printing_operations = 0;
1892         print_unbuffered--;
1893
1894         UNGCPRO;
1895 }
1896
1897 void debug_short_backtrace(int length)
1898 {
1899         int first = 1;
1900         struct backtrace *bt = backtrace_list;
1901         stderr_out("   [");
1902         while (length > 0 && bt) {
1903                 if (!first) {
1904                         stderr_out(", ");
1905                 }
1906                 if (COMPILED_FUNCTIONP(*bt->function)) {
1907 #if defined(COMPILED_FUNCTION_ANNOTATION_HACK)
1908                         Lisp_Object ann =
1909                             compiled_function_annotation(XCOMPILED_FUNCTION
1910                                                          (*bt->function));
1911 #else
1912                         Lisp_Object ann = Qnil;
1913 #endif
1914                         if (!NILP(ann)) {
1915                                 stderr_out("<compiled-function from ");
1916                                 debug_print_no_newline(ann);
1917                                 stderr_out(">");
1918                         } else {
1919                                 stderr_out
1920                                     ("<compiled-function of unknown origin>");
1921                         }
1922                 } else
1923                         debug_print_no_newline(*bt->function);
1924                 first = 0;
1925                 length--;
1926                 bt = bt->next;
1927         }
1928         stderr_out("]\n");
1929 }
1930
1931 #endif                          /* debugging kludge */
1932 \f
1933 void syms_of_print(void)
1934 {
1935         defsymbol(&Qstandard_output, "standard-output");
1936
1937         defsymbol(&Qprint_length, "print-length");
1938
1939         defsymbol(&Qprint_string_length, "print-string-length");
1940
1941         defsymbol(&Qdisplay_error, "display-error");
1942         defsymbol(&Qprint_message_label, "print-message-label");
1943
1944         DEFSUBR(Fprin1);
1945         DEFSUBR(Fprin1_to_string);
1946         DEFSUBR(Fprinc);
1947         DEFSUBR(Fprint);
1948         DEFSUBR(Ferror_message_string);
1949         DEFSUBR(Fdisplay_error);
1950         DEFSUBR(Fterpri);
1951         DEFSUBR(Fwrite_char);
1952         DEFSUBR(Falternate_debugging_output);
1953         DEFSUBR(Fexternal_debugging_output);
1954         DEFSUBR(Fopen_termscript);
1955         defsymbol(&Qexternal_debugging_output, "external-debugging-output");
1956         defsymbol(&Qalternate_debugging_output, "alternate-debugging-output");
1957         DEFSUBR(Fwith_output_to_temp_buffer);
1958 }
1959
1960 void reinit_vars_of_print(void)
1961 {
1962         alternate_do_pointer = 0;
1963 }
1964
1965 void vars_of_print(void)
1966 {
1967         reinit_vars_of_print();
1968
1969         DEFVAR_LISP("standard-output", &Vstandard_output        /*
1970 Output stream `print' uses by default for outputting a character.
1971 This may be any function of one argument.
1972 It may also be a buffer (output is inserted before point)
1973 or a marker (output is inserted and the marker is advanced)
1974 or the symbol t (output appears in the minibuffer line).
1975                                                                  */ );
1976         Vstandard_output = Qt;
1977
1978 #ifdef HAVE_FPFLOAT
1979         DEFVAR_LISP("float-output-format", &Vfloat_output_format        /*
1980 The format descriptor string that lisp uses to print floats.
1981 This is a %-spec like those accepted by `printf' in C,
1982 but with some restrictions.  It must start with the two characters `%.'.
1983 After that comes an integer precision specification,
1984 and then a letter which controls the format.
1985 The letters allowed are `e', `f' and `g'.
1986 Use `e' for exponential notation "DIG.DIGITSeEXPT"
1987 Use `f' for decimal point notation "DIGITS.DIGITS".
1988 Use `g' to choose the shorter of those two formats for the number at hand.
1989 The precision in any of these cases is the number of digits following
1990 the decimal point.  With `f', a precision of 0 means to omit the
1991 decimal point.  0 is not allowed with `f' or `g'.
1992
1993 A value of nil means to use `%.16g'.
1994
1995 Regardless of the value of `float-output-format', a floating point number
1996 will never be printed in such a way that it is ambiguous with an integer;
1997 that is, a floating-point number will always be printed with a decimal
1998 point and/or an exponent, even if the digits following the decimal point
1999 are all zero.  This is to preserve read-equivalence.
2000                                                                          */ );
2001         Vfloat_output_format = Qnil;
2002 #endif                          /* HAVE_FPFLOAT */
2003
2004         DEFVAR_LISP("print-length", &Vprint_length      /*
2005 Maximum length of list or vector to print before abbreviating.
2006 A value of nil means no limit.
2007                                                          */ );
2008         Vprint_length = Qnil;
2009
2010         DEFVAR_LISP("print-string-length", &Vprint_string_length        /*
2011 Maximum length of string to print before abbreviating.
2012 A value of nil means no limit.
2013                                                                          */ );
2014         Vprint_string_length = Qnil;
2015
2016         DEFVAR_LISP("print-level", &Vprint_level        /*
2017 Maximum depth of list nesting to print before abbreviating.
2018 A value of nil means no limit.
2019                                                          */ );
2020         Vprint_level = Qnil;
2021
2022         DEFVAR_BOOL("print-escape-newlines", &print_escape_newlines     /*
2023 Non-nil means print newlines in strings as backslash-n.
2024                                                                          */ );
2025         print_escape_newlines = 0;
2026
2027         DEFVAR_BOOL("print-readably", &print_readably   /*
2028 If non-nil, then all objects will be printed in a readable form.
2029 If an object has no readable representation, then an error is signalled.
2030 When print-readably is true, compiled-function objects will be written in
2031 #[...] form instead of in #<compiled-function [...]> form, and two-element
2032 lists of the form (quote object) will be written as the equivalent 'object.
2033 Do not SET this variable; bind it instead.
2034                                                          */ );
2035         print_readably = 0;
2036
2037         /* #### I think this should default to t.  But we'd better wait
2038            until we see that it works out.  */
2039         DEFVAR_LISP("print-gensym", &Vprint_gensym      /*
2040 If non-nil, then uninterned symbols will be printed specially.
2041 Uninterned symbols are those which are not present in `obarray', that is,
2042 those which were made with `make-symbol' or by calling `intern' with a
2043 second argument.
2044
2045 When print-gensym is true, such symbols will be preceded by "#:",
2046 which causes the reader to create a new symbol instead of interning
2047 and returning an existing one.  Beware: the #: syntax creates a new
2048 symbol each time it is seen, so if you print an object which contains
2049 two pointers to the same uninterned symbol, `read' will not duplicate
2050 that structure.
2051
2052 If the value of `print-gensym' is a cons cell, then in addition
2053 refrain from clearing `print-gensym-alist' on entry to and exit from
2054 printing functions, so that the use of #...# and #...= can carry over
2055 for several separately printed objects.
2056                                                          */ );
2057         Vprint_gensym = Qnil;
2058
2059         DEFVAR_LISP("print-gensym-alist", &Vprint_gensym_alist  /*
2060 Association list of elements (GENSYM . N) to guide use of #N# and #N=.
2061 In each element, GENSYM is an uninterned symbol that has been associated
2062 with #N= for the specified value of N.
2063                                                                  */ );
2064         Vprint_gensym_alist = Qnil;
2065
2066         DEFVAR_LISP("print-message-label", &Vprint_message_label        /*
2067 Label for minibuffer messages created with `print'.  This should
2068 generally be bound with `let' rather than set.  (See `display-message'.)
2069                                                                          */ );
2070         Vprint_message_label = Qprint;
2071
2072         DEFVAR_LISP("custom-object-printer", &Vcustom_object_printer /*
2073 Function to call in order to print custom object.
2074                                                            */ );
2075         Vcustom_object_printer = Qnil;
2076 }