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