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