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