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