1 /* Lisp object printing and output streams.
2 Copyright (C) 1985, 1986, 1988, 1992-1995 Free Software Foundation, Inc.
3 Copyright (C) 1995, 1996 Ben Wing.
5 This file is part of XEmacs.
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
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
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. */
22 /* Synched up with: Not synched with FSF. */
24 /* This file has been Mule-ized. */
26 /* Seriously hacked on by Ben Wing for Mule. */
31 #include "backtrace.h"
34 #include "console-tty.h"
35 #include "console-stream.h"
44 /* Define if not in float.h */
49 Lisp_Object Vstandard_output, Qstandard_output;
51 /* The subroutine object for external-debugging-output is kept here
52 for the convenience of the debugger. */
53 Lisp_Object Qexternal_debugging_output;
55 /* Avoid actual stack overflow in print. */
56 static int print_depth;
58 /* Detect most circularities to print finite output. */
59 #define PRINT_CIRCLE 200
60 static Lisp_Object being_printed[PRINT_CIRCLE];
62 /* Maximum length of list or vector to print in full; noninteger means
63 effectively infinity */
65 Lisp_Object Vprint_length;
66 Lisp_Object Qprint_length;
68 /* Maximum length of string to print in full; noninteger means
69 effectively infinity */
71 Lisp_Object Vprint_string_length;
72 Lisp_Object Qprint_string_length;
74 /* Maximum depth of list to print in full; noninteger means
75 effectively infinity. */
77 Lisp_Object Vprint_level;
79 /* Label to use when making echo-area messages. */
81 Lisp_Object Vprint_message_label;
83 /* Nonzero means print newlines in strings as \n. */
85 int print_escape_newlines;
88 /* Non-nil means print #: before uninterned symbols.
89 Neither t nor nil means so that and don't clear Vprint_gensym_alist
90 on entry to and exit from print functions. */
91 Lisp_Object Vprint_gensym;
92 Lisp_Object Vprint_gensym_alist;
94 Lisp_Object Qdisplay_error;
95 Lisp_Object Qprint_message_label;
97 /* Force immediate output of all printed data. Used for debugging. */
100 FILE *termscript; /* Stdio stream being used for copy of all output. */
104 int stdout_needs_newline;
106 /* Write a string (in internal format) to stdio stream STREAM. */
109 write_string_to_stdio_stream (FILE *stream, struct console *con,
111 Bytecount offset, Bytecount len,
112 Lisp_Object coding_system)
115 const Extbyte *extptr;
117 TO_EXTERNAL_FORMAT (DATA, (str + offset, len),
118 ALLOCA, (extptr, extlen),
122 fwrite (extptr, 1, extlen, stream);
124 /* Q122442 says that pipes are "treated as files, not as
125 devices", and that this is a feature. Before I found that
126 article, I thought it was a bug. Thanks MS, I feel much
128 if (stream == stdout || stream == stderr)
134 assert (CONSOLE_TTY_P (con));
135 Lstream_write (XLSTREAM (CONSOLE_TTY_DATA (con)->outstream),
138 if (stream == stdout || stream == stderr ||
139 (!stream && CONSOLE_TTY_DATA (con)->is_stdio))
143 fwrite (extptr, 1, extlen, termscript);
146 stdout_needs_newline = (extptr[extlen - 1] != '\n');
150 /* Write a string to the output location specified in FUNCTION.
151 Arguments NONRELOC, RELOC, OFFSET, and LEN are as in
152 buffer_insert_string_1() in insdel.c. */
155 output_string (Lisp_Object function, const Bufbyte *nonreloc,
156 Lisp_Object reloc, Bytecount offset, Bytecount len)
158 /* This function can GC */
160 /* We change the value of nonreloc (fetching it from reloc as
161 necessary), but we don't want to pass this changed value on to
162 other functions that take both a nonreloc and a reloc, or things
163 may get confused and an assertion failure in
164 fixup_internal_substring() may get triggered. */
165 const Bufbyte *newnonreloc = nonreloc;
166 struct gcpro gcpro1, gcpro2;
168 /* Emacs won't print while GCing, but an external debugger might */
169 if (gc_in_progress) return;
171 /* Perhaps not necessary but probably safer. */
172 GCPRO2 (function, reloc);
174 fixup_internal_substring (newnonreloc, reloc, offset, &len);
177 newnonreloc = XSTRING_DATA (reloc);
179 cclen = bytecount_to_charcount (newnonreloc + offset, len);
181 if (LSTREAMP (function))
185 /* Protect against Lstream_write() causing a GC and
186 relocating the string. For small strings, we do it by
187 alloc'ing the string and using a copy; for large strings,
191 Bufbyte *copied = alloca_array (Bufbyte, len);
192 memcpy (copied, newnonreloc + offset, len);
193 Lstream_write (XLSTREAM (function), copied, len);
197 int speccount = specpdl_depth ();
198 record_unwind_protect (restore_gc_inhibit,
199 make_int (gc_currently_forbidden));
200 gc_currently_forbidden = 1;
201 Lstream_write (XLSTREAM (function), newnonreloc + offset, len);
202 unbind_to (speccount, Qnil);
206 Lstream_write (XLSTREAM (function), newnonreloc + offset, len);
208 if (print_unbuffered)
209 Lstream_flush (XLSTREAM (function));
211 else if (BUFFERP (function))
213 CHECK_LIVE_BUFFER (function);
214 buffer_insert_string (XBUFFER (function), nonreloc, reloc, offset, len);
216 else if (MARKERP (function))
218 /* marker_position() will err if marker doesn't point anywhere. */
219 Bufpos spoint = marker_position (function);
221 buffer_insert_string_1 (XMARKER (function)->buffer,
222 spoint, nonreloc, reloc, offset, len,
224 Fset_marker (function, make_int (spoint + cclen),
225 Fmarker_buffer (function));
227 else if (FRAMEP (function))
229 /* This gets used by functions not invoking print_prepare(),
230 such as Fwrite_char, Fterpri, etc.. */
231 struct frame *f = XFRAME (function);
232 CHECK_LIVE_FRAME (function);
234 if (!EQ (Vprint_message_label, echo_area_status (f)))
235 clear_echo_area_from_print (f, Qnil, 1);
236 echo_area_append (f, nonreloc, reloc, offset, len, Vprint_message_label);
238 else if (EQ (function, Qt) || EQ (function, Qnil))
240 write_string_to_stdio_stream (stdout, 0, newnonreloc, offset, len,
245 Charcount ccoff = bytecount_to_charcount (newnonreloc, offset);
248 for (iii = ccoff; iii < cclen + ccoff; iii++)
251 make_char (charptr_emchar_n (newnonreloc, iii)));
253 newnonreloc = XSTRING_DATA (reloc);
260 #define RESET_PRINT_GENSYM do { \
261 if (!CONSP (Vprint_gensym)) \
262 Vprint_gensym_alist = Qnil; \
266 canonicalize_printcharfun (Lisp_Object printcharfun)
268 if (NILP (printcharfun))
269 printcharfun = Vstandard_output;
271 if (EQ (printcharfun, Qt) || NILP (printcharfun))
272 printcharfun = Fselected_frame (Qnil); /* print to minibuffer */
278 print_prepare (Lisp_Object printcharfun, Lisp_Object *frame_kludge)
280 /* Emacs won't print while GCing, but an external debugger might */
286 printcharfun = canonicalize_printcharfun (printcharfun);
288 /* Here we could safely return the canonicalized PRINTCHARFUN.
289 However, if PRINTCHARFUN is a frame, printing of complex
290 structures becomes very expensive, because `append-message'
291 (called by echo_area_append) gets called as many times as
292 output_string() is called (and that's a *lot*). append-message
293 tries to keep top of the message-stack in sync with the contents
294 of " *Echo Area" buffer, consing a new string for each component
295 of the printed structure. For instance, if you print (a a),
296 append-message will cons up the following strings:
304 and will use only the last one. With larger objects, this turns
305 into an O(n^2) consing frenzy that locks up XEmacs in incessant
308 We prevent this by creating a resizing_buffer stream and letting
309 the printer write into it. print_finish() will notice this
310 stream, and invoke echo_area_append() with the stream's buffer,
312 if (FRAMEP (printcharfun))
314 CHECK_LIVE_FRAME (printcharfun);
315 *frame_kludge = printcharfun;
316 printcharfun = make_resizing_buffer_output_stream ();
323 print_finish (Lisp_Object stream, Lisp_Object frame_kludge)
325 /* Emacs won't print while GCing, but an external debugger might */
331 /* See the comment in print_prepare(). */
332 if (FRAMEP (frame_kludge))
334 struct frame *f = XFRAME (frame_kludge);
335 Lstream *str = XLSTREAM (stream);
336 CHECK_LIVE_FRAME (frame_kludge);
339 if (!EQ (Vprint_message_label, echo_area_status (f)))
340 clear_echo_area_from_print (f, Qnil, 1);
341 echo_area_append (f, resizing_buffer_stream_ptr (str),
342 Qnil, 0, Lstream_byte_count (str),
343 Vprint_message_label);
344 Lstream_delete (str);
348 /* Used for printing a single-byte character (*not* any Emchar). */
349 #define write_char_internal(string_of_length_1, stream) \
350 output_string (stream, (const Bufbyte *) (string_of_length_1), \
353 /* NOTE: Do not call this with the data of a Lisp_String, as
354 printcharfun might cause a GC, which might cause the string's data
355 to be relocated. To princ a Lisp string, use:
357 print_internal (string, printcharfun, 0);
359 Also note that STREAM should be the result of
360 canonicalize_printcharfun() (i.e. Qnil means stdout, not
361 Vstandard_output, etc.) */
363 write_string_1 (const Bufbyte *str, Bytecount size, Lisp_Object stream)
365 /* This function can GC */
366 #ifdef ERROR_CHECK_BUFPOS
369 output_string (stream, str, Qnil, 0, size);
373 write_c_string (const char *str, Lisp_Object stream)
375 /* This function can GC */
376 write_string_1 ((const Bufbyte *) str, strlen (str), stream);
380 DEFUN ("write-char", Fwrite_char, 1, 2, 0, /*
381 Output character CH to stream STREAM.
382 STREAM defaults to the value of `standard-output' (which see).
386 /* This function can GC */
387 Bufbyte str[MAX_EMCHAR_LEN];
390 CHECK_CHAR_COERCE_INT (ch);
391 len = set_charptr_emchar (str, XCHAR (ch));
392 output_string (canonicalize_printcharfun (stream), str, Qnil, 0, len);
397 temp_output_buffer_setup (Lisp_Object bufname)
399 /* This function can GC */
400 struct buffer *old = current_buffer;
404 /* #### This function should accept a Lisp_Object instead of a char *,
405 so that proper translation on the buffer name can occur. */
408 Fset_buffer (Fget_buffer_create (bufname));
410 current_buffer->read_only = Qnil;
411 Ferase_buffer (Qnil);
413 XSETBUFFER (buf, current_buffer);
414 specbind (Qstandard_output, buf);
416 set_buffer_internal (old);
420 internal_with_output_to_temp_buffer (Lisp_Object bufname,
421 Lisp_Object (*function) (Lisp_Object arg),
423 Lisp_Object same_frame)
425 int speccount = specpdl_depth ();
426 struct gcpro gcpro1, gcpro2, gcpro3;
427 Lisp_Object buf = Qnil;
429 GCPRO3 (buf, arg, same_frame);
431 temp_output_buffer_setup (bufname);
432 buf = Vstandard_output;
434 arg = (*function) (arg);
436 temp_output_buffer_show (buf, same_frame);
439 return unbind_to (speccount, arg);
442 DEFUN ("with-output-to-temp-buffer", Fwith_output_to_temp_buffer, 1, UNEVALLED, 0, /*
443 Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
444 The buffer is cleared out initially, and marked as unmodified when done.
445 All output done by BODY is inserted in that buffer by default.
446 The buffer is displayed in another window, but not selected.
447 The value of the last form in BODY is returned.
448 If BODY does not finish normally, the buffer BUFNAME is not displayed.
450 If variable `temp-buffer-show-function' is non-nil, call it at the end
451 to get the buffer displayed. It gets one argument, the buffer to display.
455 /* This function can GC */
456 Lisp_Object name = Qnil;
457 int speccount = specpdl_depth ();
458 struct gcpro gcpro1, gcpro2;
459 Lisp_Object val = Qnil;
462 /* #### should set the buffer to be translating. See print_internal(). */
466 name = Feval (XCAR (args));
470 temp_output_buffer_setup (name);
473 val = Fprogn (XCDR (args));
475 temp_output_buffer_show (Vstandard_output, Qnil);
477 return unbind_to (speccount, val);
480 DEFUN ("terpri", Fterpri, 0, 1, 0, /*
481 Output a newline to STREAM.
482 If STREAM is omitted or nil, the value of `standard-output' is used.
486 /* This function can GC */
487 write_char_internal ("\n", canonicalize_printcharfun (stream));
491 DEFUN ("prin1", Fprin1, 1, 2, 0, /*
492 Output the printed representation of OBJECT, any Lisp object.
493 Quoting characters are printed when needed to make output that `read'
494 can handle, whenever this is possible.
495 Output stream is STREAM, or value of `standard-output' (which see).
499 /* This function can GC */
500 Lisp_Object frame = Qnil;
501 struct gcpro gcpro1, gcpro2;
502 GCPRO2 (object, stream);
505 stream = print_prepare (stream, &frame);
506 print_internal (object, stream, 1);
507 print_finish (stream, frame);
513 DEFUN ("prin1-to-string", Fprin1_to_string, 1, 2, 0, /*
514 Return a string containing the printed representation of OBJECT,
515 any Lisp object. Quoting characters are used when needed to make output
516 that `read' can handle, whenever this is possible, unless the optional
517 second argument NOESCAPE is non-nil.
521 /* This function can GC */
522 Lisp_Object result = Qnil;
523 Lisp_Object stream = make_resizing_buffer_output_stream ();
524 Lstream *str = XLSTREAM (stream);
525 /* gcpro OBJECT in case a caller forgot to do so */
526 struct gcpro gcpro1, gcpro2, gcpro3;
527 GCPRO3 (object, stream, result);
531 print_internal (object, stream, NILP (noescape));
535 result = make_string (resizing_buffer_stream_ptr (str),
536 Lstream_byte_count (str));
537 Lstream_delete (str);
541 DEFUN ("princ", Fprinc, 1, 2, 0, /*
542 Output the printed representation of OBJECT, any Lisp object.
543 No quoting characters are used; no delimiters are printed around
544 the contents of strings.
545 Output stream is STREAM, or value of standard-output (which see).
549 /* This function can GC */
550 Lisp_Object frame = Qnil;
551 struct gcpro gcpro1, gcpro2;
553 GCPRO2 (object, stream);
554 stream = print_prepare (stream, &frame);
556 print_internal (object, stream, 0);
557 print_finish (stream, frame);
562 DEFUN ("print", Fprint, 1, 2, 0, /*
563 Output the printed representation of OBJECT, with newlines around it.
564 Quoting characters are printed when needed to make output that `read'
565 can handle, whenever this is possible.
566 Output stream is STREAM, or value of `standard-output' (which see).
570 /* This function can GC */
571 Lisp_Object frame = Qnil;
572 struct gcpro gcpro1, gcpro2;
574 GCPRO2 (object, stream);
575 stream = print_prepare (stream, &frame);
577 write_char_internal ("\n", stream);
578 print_internal (object, stream, 1);
579 write_char_internal ("\n", stream);
580 print_finish (stream, frame);
585 /* Print an error message for the error DATA to STREAM. This is a
586 complete implementation of `display-error', which used to be in
587 Lisp (see prim/cmdloop.el). It was ported to C so it can be used
588 efficiently by Ferror_message_string. Fdisplay_error and
589 Ferror_message_string are trivial wrappers around this function.
591 STREAM should be the result of canonicalize_printcharfun(). */
593 print_error_message (Lisp_Object error_object, Lisp_Object stream)
595 /* This function can GC */
596 Lisp_Object type = Fcar_safe (error_object);
597 Lisp_Object method = Qnil;
600 /* No need to GCPRO anything under the assumption that ERROR_OBJECT
603 if (! (CONSP (error_object) && SYMBOLP (type)
604 && CONSP (Fget (type, Qerror_conditions, Qnil))))
607 tail = XCDR (error_object);
615 tail = Fget (type, Qerror_conditions, Qnil);
618 if (!(CONSP (tail) && SYMBOLP (XCAR (tail))))
620 else if (!NILP (Fget (XCAR (tail), Qdisplay_error, Qnil)))
622 method = Fget (XCAR (tail), Qdisplay_error, Qnil);
631 int speccount = specpdl_depth ();
632 Lisp_Object frame = Qnil;
636 specbind (Qprint_message_label, Qerror);
637 stream = print_prepare (stream, &frame);
639 tail = Fcdr (error_object);
640 if (EQ (type, Qerror))
642 print_internal (Fcar (tail), stream, 0);
647 Lisp_Object errmsg = Fget (type, Qerror_message, Qnil);
649 print_internal (type, stream, 0);
651 print_internal (LISP_GETTEXT (errmsg), stream, 0);
655 write_c_string (first ? ": " : ", ", stream);
656 print_internal (Fcar (tail), stream, 1);
660 print_finish (stream, frame);
662 unbind_to (speccount, Qnil);
670 write_c_string (GETTEXT ("Peculiar error "), stream);
671 print_internal (error_object, stream, 1);
676 call2 (method, error_object, stream);
680 DEFUN ("error-message-string", Ferror_message_string, 1, 1, 0, /*
681 Convert ERROR-OBJECT to an error message, and return it.
683 The format of ERROR-OBJECT should be (ERROR-SYMBOL . DATA). The
684 message is equivalent to the one that would be issued by
685 `display-error' with the same argument.
689 /* This function can GC */
690 Lisp_Object result = Qnil;
691 Lisp_Object stream = make_resizing_buffer_output_stream ();
695 print_error_message (error_object, stream);
696 Lstream_flush (XLSTREAM (stream));
697 result = make_string (resizing_buffer_stream_ptr (XLSTREAM (stream)),
698 Lstream_byte_count (XLSTREAM (stream)));
699 Lstream_delete (XLSTREAM (stream));
705 DEFUN ("display-error", Fdisplay_error, 2, 2, 0, /*
706 Display ERROR-OBJECT on STREAM in a user-friendly way.
708 (error_object, stream))
710 /* This function can GC */
711 print_error_message (error_object, canonicalize_printcharfun (stream));
716 #ifdef LISP_FLOAT_TYPE
718 Lisp_Object Vfloat_output_format;
721 * This buffer should be at least as large as the max string size of the
722 * largest float, printed in the biggest notation. This is undoubtedly
723 * 20d float_output_format, with the negative of the C-constant "HUGE"
726 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
728 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
729 * case of -1e307 in 20d float_output_format. What is one to do (short of
730 * re-writing _doprnt to be more sane)?
734 float_to_string (char *buf, double data)
739 if (NILP (Vfloat_output_format)
740 || !STRINGP (Vfloat_output_format))
742 sprintf (buf, "%.16g", data);
745 /* Check that the spec we have is fully valid.
746 This means not only valid for printf,
747 but meant for floats, and reasonable. */
748 cp = XSTRING_DATA (Vfloat_output_format);
756 for (width = 0; (c = *cp, isdigit (c)); cp++)
762 if (*cp != 'e' && *cp != 'f' && *cp != 'g' && *cp != 'E' && *cp != 'G')
765 if (width < (int) (*cp != 'e' && *cp != 'E') || width > DBL_DIG)
771 sprintf (buf, (char *) XSTRING_DATA (Vfloat_output_format),
775 /* added by jwz: don't allow "1.0" to print as "1"; that destroys
776 the read-equivalence of lisp objects. (* x 1) and (* x 1.0) do
777 not do the same thing, so it's important that the printed
778 representation of that form not be corrupted by the printer.
781 Bufbyte *s = (Bufbyte *) buf; /* don't use signed chars here!
782 isdigit() can't hack them! */
785 /* if there's a non-digit, then there is a decimal point, or
786 it's in exponential notation, both of which are ok. */
789 /* otherwise, we need to hack it. */
796 /* Some machines print "0.4" as ".4". I don't like that. */
797 if (buf [0] == '.' || (buf [0] == '-' && buf [1] == '.'))
800 for (i = strlen (buf) + 1; i >= 0; i--)
802 buf [(buf [0] == '-' ? 1 : 0)] = '0';
805 #endif /* LISP_FLOAT_TYPE */
807 /* Print NUMBER to BUFFER. The digits are first written in reverse
808 order (the least significant digit first), and are then reversed.
809 This is equivalent to sprintf(buffer, "%ld", number), only much
812 BUFFER should accept 24 bytes. This should suffice for the longest
813 numbers on 64-bit machines, including the `-' sign and the trailing
816 long_to_string (char *buffer, long number)
818 #if (SIZEOF_LONG != 4) && (SIZEOF_LONG != 8)
820 sprintf (buffer, "%ld", number);
821 #else /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
831 #define FROB(figure) do { \
832 if (force || number >= figure) \
833 *p++ = number / figure + '0', number %= figure, force = 1; \
836 FROB (1000000000000000000L);
837 FROB (100000000000000000L);
838 FROB (10000000000000000L);
839 FROB (1000000000000000L);
840 FROB (100000000000000L);
841 FROB (10000000000000L);
842 FROB (1000000000000L);
843 FROB (100000000000L);
845 #endif /* SIZEOF_LONG == 8 */
858 #endif /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
862 print_vector_internal (const char *start, const char *end,
864 Lisp_Object printcharfun, int escapeflag)
866 /* This function can GC */
868 int len = XVECTOR_LENGTH (obj);
870 struct gcpro gcpro1, gcpro2;
871 GCPRO2 (obj, printcharfun);
873 if (INTP (Vprint_length))
875 int max = XINT (Vprint_length);
876 if (max < len) last = max;
879 write_c_string (start, printcharfun);
880 for (i = 0; i < last; i++)
882 Lisp_Object elt = XVECTOR_DATA (obj)[i];
883 if (i != 0) write_char_internal (" ", printcharfun);
884 print_internal (elt, printcharfun, escapeflag);
888 write_c_string (" ...", printcharfun);
889 write_c_string (end, printcharfun);
893 print_cons (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
895 /* This function can GC */
896 struct gcpro gcpro1, gcpro2;
898 /* If print_readably is on, print (quote -foo-) as '-foo-
899 (Yeah, this should really be what print-pretty does, but we
900 don't have the rest of a pretty printer, and this actually
901 has non-negligible impact on size/speed of .elc files.)
903 if (print_readably &&
904 EQ (XCAR (obj), Qquote) &&
905 CONSP (XCDR (obj)) &&
906 NILP (XCDR (XCDR (obj))))
908 obj = XCAR (XCDR (obj));
909 GCPRO2 (obj, printcharfun);
910 write_char_internal ("\'", printcharfun);
912 print_internal (obj, printcharfun, escapeflag);
916 GCPRO2 (obj, printcharfun);
917 write_char_internal ("(", printcharfun);
921 int max = INTP (Vprint_length) ? XINT (Vprint_length) : INT_MAX;
922 Lisp_Object tortoise;
923 /* Use tortoise/hare to make sure circular lists don't infloop */
925 for (tortoise = obj, len = 0;
927 obj = XCDR (obj), len++)
930 write_char_internal (" ", printcharfun);
931 if (EQ (obj, tortoise) && len > 0)
934 error ("printing unreadable circular list");
936 write_c_string ("... <circular list>", printcharfun);
940 tortoise = XCDR (tortoise);
943 write_c_string ("...", printcharfun);
946 print_internal (XCAR (obj), printcharfun, escapeflag);
951 write_c_string (" . ", printcharfun);
952 print_internal (obj, printcharfun, escapeflag);
956 write_char_internal (")", printcharfun);
961 print_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
963 print_vector_internal ("[", "]", obj, printcharfun, escapeflag);
967 print_string (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
969 Lisp_String *s = XSTRING (obj);
970 /* We distinguish between Bytecounts and Charcounts, to make
971 Vprint_string_length work correctly under Mule. */
972 Charcount size = string_char_length (s);
973 Charcount max = size;
974 Bytecount bcmax = string_length (s);
975 struct gcpro gcpro1, gcpro2;
976 GCPRO2 (obj, printcharfun);
978 if (INTP (Vprint_string_length) &&
979 XINT (Vprint_string_length) < max)
981 max = XINT (Vprint_string_length);
982 bcmax = charcount_to_bytecount (string_data (s), max);
992 /* This deals with GC-relocation and Mule. */
993 output_string (printcharfun, 0, obj, 0, bcmax);
995 write_c_string (" ...", printcharfun);
999 Bytecount i, last = 0;
1001 write_char_internal ("\"", printcharfun);
1002 for (i = 0; i < bcmax; i++)
1004 Bufbyte ch = string_byte (s, i);
1005 if (ch == '\"' || ch == '\\'
1006 || (ch == '\n' && print_escape_newlines))
1010 output_string (printcharfun, 0, obj, last,
1015 write_c_string ("\\n", printcharfun);
1019 write_char_internal ("\\", printcharfun);
1020 /* This is correct for Mule because the
1021 character is either \ or " */
1022 write_char_internal (string_data (s) + i, printcharfun);
1029 output_string (printcharfun, 0, obj, last,
1033 write_c_string (" ...", printcharfun);
1034 write_char_internal ("\"", printcharfun);
1040 default_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
1043 struct lcrecord_header *header =
1044 (struct lcrecord_header *) XPNTR (obj);
1048 error ("printing unreadable object #<%s 0x%x>",
1049 LHEADER_IMPLEMENTATION (&header->lheader)->name,
1052 sprintf (buf, "#<%s 0x%x>",
1053 LHEADER_IMPLEMENTATION (&header->lheader)->name,
1055 write_c_string (buf, printcharfun);
1059 internal_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
1063 sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%lx>",
1064 XRECORD_LHEADER_IMPLEMENTATION (obj)->name,
1065 (unsigned long) XPNTR (obj));
1066 write_c_string (buf, printcharfun);
1070 print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1072 /* This function can GC */
1076 /* Emacs won't print while GCing, but an external debugger might */
1077 if (gc_in_progress) return;
1080 /* #### Both input and output streams should have a flag associated
1081 with them indicating whether output to that stream, or strings
1082 read from the stream, get translated using Fgettext(). Such a
1083 stream is called a "translating stream". For the minibuffer and
1084 external-debugging-output this is always true on output, and
1085 with-output-to-temp-buffer sets the flag to true for the buffer
1086 it creates. This flag should also be user-settable. Perhaps it
1087 should be split up into two flags, one for input and one for
1091 /* Detect circularities and truncate them.
1092 No need to offer any alternative--this is better than an error. */
1093 if (CONSP (obj) || VECTORP (obj) || COMPILED_FUNCTIONP (obj))
1096 for (i = 0; i < print_depth; i++)
1097 if (EQ (obj, being_printed[i]))
1101 long_to_string (buf + 1, i);
1102 write_c_string (buf, printcharfun);
1107 being_printed[print_depth] = obj;
1110 if (print_depth > PRINT_CIRCLE)
1111 error ("Apparently circular structure being printed");
1113 switch (XTYPE (obj))
1115 case Lisp_Type_Int_Even:
1116 case Lisp_Type_Int_Odd:
1118 /* ASCII Decimal representation uses 2.4 times as many bits as
1120 char buf[3 * sizeof (EMACS_INT) + 5];
1121 long_to_string (buf, XINT (obj));
1122 write_c_string (buf, printcharfun);
1126 case Lisp_Type_Char:
1128 /* God intended that this be #\..., you know. */
1130 Emchar ch = XCHAR (obj);
1138 case '\t': *p++ = 't'; break;
1139 case '\n': *p++ = 'n'; break;
1140 case '\r': *p++ = 'r'; break;
1144 if ((ch + 64) == '\\')
1151 /* syntactically special characters should be escaped. */
1174 *p++ = '\\', *p++ = '^', *p++ = '?';
1178 *p++ = '\\', *p++ = '^';
1179 p += set_charptr_emchar ((Bufbyte *) p, ch + 64);
1183 p += set_charptr_emchar ((Bufbyte *) p, ch);
1186 output_string (printcharfun, (Bufbyte *) buf, Qnil, 0, p - buf);
1191 case Lisp_Type_Record:
1193 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
1194 struct gcpro gcpro1, gcpro2;
1196 if (CONSP (obj) || VECTORP(obj))
1198 /* If deeper than spec'd depth, print placeholder. */
1199 if (INTP (Vprint_level)
1200 && print_depth > XINT (Vprint_level))
1202 GCPRO2 (obj, printcharfun);
1203 write_c_string ("...", printcharfun);
1209 GCPRO2 (obj, printcharfun);
1210 if (LHEADER_IMPLEMENTATION (lheader)->printer)
1211 ((LHEADER_IMPLEMENTATION (lheader)->printer)
1212 (obj, printcharfun, escapeflag));
1214 default_object_printer (obj, printcharfun, escapeflag);
1221 #ifdef ERROR_CHECK_TYPECHECK
1223 #else /* not ERROR_CHECK_TYPECHECK */
1225 /* We're in trouble if this happens! */
1227 error ("printing illegal data type #o%03o",
1229 write_c_string ("#<EMACS BUG: ILLEGAL DATATYPE ",
1231 sprintf (buf, "(#o%3o)", (int) XTYPE (obj));
1232 write_c_string (buf, printcharfun);
1234 (" Save your buffers immediately and please report this bug>",
1236 #endif /* not ERROR_CHECK_TYPECHECK */
1245 #ifdef LISP_FLOAT_TYPE
1247 print_float (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1249 char pigbuf[350]; /* see comments in float_to_string */
1251 float_to_string (pigbuf, XFLOAT_DATA (obj));
1252 write_c_string (pigbuf, printcharfun);
1254 #endif /* LISP_FLOAT_TYPE */
1257 print_symbol (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1259 /* This function can GC */
1260 /* #### Bug!! (intern "") isn't printed in some distinguished way */
1261 /* #### (the reader also loses on it) */
1262 Lisp_String *name = symbol_name (XSYMBOL (obj));
1263 Bytecount size = string_length (name);
1264 struct gcpro gcpro1, gcpro2;
1268 /* This deals with GC-relocation */
1269 Lisp_Object nameobj;
1270 XSETSTRING (nameobj, name);
1271 output_string (printcharfun, 0, nameobj, 0, size);
1274 GCPRO2 (obj, printcharfun);
1276 /* If we print an uninterned symbol as part of a complex object and
1277 the flag print-gensym is non-nil, prefix it with #n= to read the
1278 object back with the #n# reader syntax later if needed. */
1279 if (!NILP (Vprint_gensym)
1280 /* #### Test whether this produces a noticable slow-down for
1281 printing when print-gensym is non-nil. */
1282 && !EQ (obj, oblookup (Vobarray,
1283 string_data (symbol_name (XSYMBOL (obj))),
1284 string_length (symbol_name (XSYMBOL (obj))))))
1286 if (print_depth > 1)
1288 Lisp_Object tem = Fassq (obj, Vprint_gensym_alist);
1291 write_char_internal ("#", printcharfun);
1292 print_internal (XCDR (tem), printcharfun, escapeflag);
1293 write_char_internal ("#", printcharfun);
1298 if (CONSP (Vprint_gensym_alist))
1300 /* Vprint_gensym_alist is exposed to Lisp, so we
1301 have to be careful. */
1302 CHECK_CONS (XCAR (Vprint_gensym_alist));
1303 CHECK_INT (XCDR (XCAR (Vprint_gensym_alist)));
1304 XSETINT (tem, XINT (XCDR (XCAR (Vprint_gensym_alist))) + 1);
1308 Vprint_gensym_alist = Fcons (Fcons (obj, tem), Vprint_gensym_alist);
1310 write_char_internal ("#", printcharfun);
1311 print_internal (tem, printcharfun, escapeflag);
1312 write_char_internal ("=", printcharfun);
1315 write_c_string ("#:", printcharfun);
1318 /* Does it look like an integer or a float? */
1320 Bufbyte *data = string_data (name);
1321 Bytecount confusing = 0;
1324 goto not_yet_confused; /* Really confusing */
1325 else if (isdigit (data[0]))
1328 goto not_yet_confused;
1329 else if (data[0] == '-' || data[0] == '+')
1332 goto not_yet_confused;
1334 for (; confusing < size; confusing++)
1336 if (!isdigit (data[confusing]))
1344 #ifdef LISP_FLOAT_TYPE
1346 /* #### Ugh, this is needlessly complex and slow for what we
1347 need here. It might be a good idea to copy equivalent code
1348 from FSF. --hniksic */
1349 confusing = isfloat_string ((char *) data);
1352 write_char_internal ("\\", printcharfun);
1356 Lisp_Object nameobj;
1360 XSETSTRING (nameobj, name);
1361 for (i = 0; i < size; i++)
1363 switch (string_byte (name, i))
1365 case 0: case 1: case 2: case 3:
1366 case 4: case 5: case 6: case 7:
1367 case 8: case 9: case 10: case 11:
1368 case 12: case 13: case 14: case 15:
1369 case 16: case 17: case 18: case 19:
1370 case 20: case 21: case 22: case 23:
1371 case 24: case 25: case 26: case 27:
1372 case 28: case 29: case 30: case 31:
1373 case ' ': case '\"': case '\\': case '\'':
1374 case ';': case '#' : case '(' : case ')':
1375 case ',': case '.' : case '`' :
1376 case '[': case ']' : case '?' :
1378 output_string (printcharfun, 0, nameobj, last, i - last);
1379 write_char_internal ("\\", printcharfun);
1383 output_string (printcharfun, 0, nameobj, last, size - last);
1388 /* #ifdef DEBUG_XEMACS */
1390 /* I don't like seeing `Note: Strange doc (not fboundp) for function
1391 alternate-debugging-output @ 429542' -slb */
1392 /* #### Eek! Any clue how to get rid of it? In fact, how about
1393 getting rid of this function altogether? Does anything actually
1394 *use* it? --hniksic */
1396 static int alternate_do_pointer;
1397 static char alternate_do_string[5000];
1399 DEFUN ("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0, /*
1400 Append CHARACTER to the array `alternate_do_string'.
1401 This can be used in place of `external-debugging-output' as a function
1402 to be passed to `print'. Before calling `print', set `alternate_do_pointer'
1407 Bufbyte str[MAX_EMCHAR_LEN];
1410 const Extbyte *extptr;
1412 CHECK_CHAR_COERCE_INT (character);
1413 len = set_charptr_emchar (str, XCHAR (character));
1414 TO_EXTERNAL_FORMAT (DATA, (str, len),
1415 ALLOCA, (extptr, extlen),
1417 memcpy (alternate_do_string + alternate_do_pointer, extptr, extlen);
1418 alternate_do_pointer += extlen;
1419 alternate_do_string[alternate_do_pointer] = 0;
1422 /* #endif / * DEBUG_XEMACS */
1424 DEFUN ("external-debugging-output", Fexternal_debugging_output, 1, 3, 0, /*
1425 Write CHAR-OR-STRING to stderr or stdout.
1426 If optional arg STDOUT-P is non-nil, write to stdout; otherwise, write
1427 to stderr. You can use this function to write directly to the terminal.
1428 This function can be used as the STREAM argument of Fprint() or the like.
1430 If you have opened a termscript file (using `open-termscript'), then
1431 the output also will be logged to this file.
1433 (char_or_string, stdout_p, device))
1436 struct console *con = 0;
1440 if (!NILP (stdout_p))
1447 CHECK_LIVE_DEVICE (device);
1448 if (!DEVICE_TTY_P (XDEVICE (device)) &&
1449 !DEVICE_STREAM_P (XDEVICE (device)))
1450 signal_simple_error ("Must be tty or stream device", device);
1451 con = XCONSOLE (DEVICE_CONSOLE (XDEVICE (device)));
1452 if (DEVICE_TTY_P (XDEVICE (device)))
1454 else if (!NILP (stdout_p))
1455 file = CONSOLE_STREAM_DATA (con)->out;
1457 file = CONSOLE_STREAM_DATA (con)->err;
1460 if (STRINGP (char_or_string))
1461 write_string_to_stdio_stream (file, con,
1462 XSTRING_DATA (char_or_string),
1463 0, XSTRING_LENGTH (char_or_string),
1467 Bufbyte str[MAX_EMCHAR_LEN];
1470 CHECK_CHAR_COERCE_INT (char_or_string);
1471 len = set_charptr_emchar (str, XCHAR (char_or_string));
1472 write_string_to_stdio_stream (file, con, str, 0, len, Qterminal);
1475 return char_or_string;
1478 DEFUN ("open-termscript", Fopen_termscript, 1, 1, "FOpen termscript file: ", /*
1479 Start writing all terminal output to FILE as well as the terminal.
1480 FILE = nil means just close any termscript file currently open.
1484 /* This function can GC */
1485 if (termscript != 0)
1486 fclose (termscript);
1491 file = Fexpand_file_name (file, Qnil);
1492 termscript = fopen ((char *) XSTRING_DATA (file), "w");
1493 if (termscript == NULL)
1494 report_file_error ("Opening termscript", list1 (file));
1500 /* Debugging kludge -- unbuffered */
1501 static int debug_print_length = 50;
1502 static int debug_print_level = 15;
1503 static int debug_print_readably = -1;
1506 debug_print_no_newline (Lisp_Object debug_print_obj)
1508 /* This function can GC */
1509 int save_print_readably = print_readably;
1510 int save_print_depth = print_depth;
1511 Lisp_Object save_Vprint_length = Vprint_length;
1512 Lisp_Object save_Vprint_level = Vprint_level;
1513 Lisp_Object save_Vinhibit_quit = Vinhibit_quit;
1514 struct gcpro gcpro1, gcpro2, gcpro3;
1515 GCPRO3 (save_Vprint_level, save_Vprint_length, save_Vinhibit_quit);
1518 stderr_out ("** gc-in-progress! Bad idea to print anything! **\n");
1521 print_readably = debug_print_readably != -1 ? debug_print_readably : 0;
1523 /* Could use unwind-protect, but why bother? */
1524 if (debug_print_length > 0)
1525 Vprint_length = make_int (debug_print_length);
1526 if (debug_print_level > 0)
1527 Vprint_level = make_int (debug_print_level);
1529 print_internal (debug_print_obj, Qexternal_debugging_output, 1);
1531 Vinhibit_quit = save_Vinhibit_quit;
1532 Vprint_level = save_Vprint_level;
1533 Vprint_length = save_Vprint_length;
1534 print_depth = save_print_depth;
1535 print_readably = save_print_readably;
1541 debug_print (Lisp_Object debug_print_obj)
1543 debug_print_no_newline (debug_print_obj);
1548 /* Debugging kludge -- unbuffered */
1549 /* This function provided for the benefit of the debugger. */
1550 void debug_backtrace (void);
1552 debug_backtrace (void)
1554 /* This function can GC */
1555 int old_print_readably = print_readably;
1556 int old_print_depth = print_depth;
1557 Lisp_Object old_print_length = Vprint_length;
1558 Lisp_Object old_print_level = Vprint_level;
1559 Lisp_Object old_inhibit_quit = Vinhibit_quit;
1561 struct gcpro gcpro1, gcpro2, gcpro3;
1562 GCPRO3 (old_print_level, old_print_length, old_inhibit_quit);
1565 stderr_out ("** gc-in-progress! Bad idea to print anything! **\n");
1570 /* Could use unwind-protect, but why bother? */
1571 if (debug_print_length > 0)
1572 Vprint_length = make_int (debug_print_length);
1573 if (debug_print_level > 0)
1574 Vprint_level = make_int (debug_print_level);
1576 Fbacktrace (Qexternal_debugging_output, Qt);
1580 Vinhibit_quit = old_inhibit_quit;
1581 Vprint_level = old_print_level;
1582 Vprint_length = old_print_length;
1583 print_depth = old_print_depth;
1584 print_readably = old_print_readably;
1591 debug_short_backtrace (int length)
1594 struct backtrace *bt = backtrace_list;
1597 while (length > 0 && bt)
1604 if (COMPILED_FUNCTIONP (*bt->function))
1606 #if defined(COMPILED_FUNCTION_ANNOTATION_HACK)
1608 compiled_function_annotation (XCOMPILED_FUNCTION (*bt->function));
1610 Lisp_Object ann = Qnil;
1614 stderr_out ("<compiled-function from ");
1616 debug_print_no_newline (ann);
1622 stderr_out ("<compiled-function of unknown origin>");
1627 debug_print_no_newline (*bt->function);
1636 #endif /* debugging kludge */
1640 syms_of_print (void)
1642 defsymbol (&Qstandard_output, "standard-output");
1644 defsymbol (&Qprint_length, "print-length");
1646 defsymbol (&Qprint_string_length, "print-string-length");
1648 defsymbol (&Qdisplay_error, "display-error");
1649 defsymbol (&Qprint_message_label, "print-message-label");
1652 DEFSUBR (Fprin1_to_string);
1655 DEFSUBR (Ferror_message_string);
1656 DEFSUBR (Fdisplay_error);
1658 DEFSUBR (Fwrite_char);
1659 DEFSUBR (Falternate_debugging_output);
1660 DEFSUBR (Fexternal_debugging_output);
1661 DEFSUBR (Fopen_termscript);
1662 defsymbol (&Qexternal_debugging_output, "external-debugging-output");
1663 DEFSUBR (Fwith_output_to_temp_buffer);
1667 reinit_vars_of_print (void)
1669 alternate_do_pointer = 0;
1673 vars_of_print (void)
1675 reinit_vars_of_print ();
1677 DEFVAR_LISP ("standard-output", &Vstandard_output /*
1678 Output stream `print' uses by default for outputting a character.
1679 This may be any function of one argument.
1680 It may also be a buffer (output is inserted before point)
1681 or a marker (output is inserted and the marker is advanced)
1682 or the symbol t (output appears in the minibuffer line).
1684 Vstandard_output = Qt;
1686 #ifdef LISP_FLOAT_TYPE
1687 DEFVAR_LISP ("float-output-format", &Vfloat_output_format /*
1688 The format descriptor string that lisp uses to print floats.
1689 This is a %-spec like those accepted by `printf' in C,
1690 but with some restrictions. It must start with the two characters `%.'.
1691 After that comes an integer precision specification,
1692 and then a letter which controls the format.
1693 The letters allowed are `e', `f' and `g'.
1694 Use `e' for exponential notation "DIG.DIGITSeEXPT"
1695 Use `f' for decimal point notation "DIGITS.DIGITS".
1696 Use `g' to choose the shorter of those two formats for the number at hand.
1697 The precision in any of these cases is the number of digits following
1698 the decimal point. With `f', a precision of 0 means to omit the
1699 decimal point. 0 is not allowed with `f' or `g'.
1701 A value of nil means to use `%.16g'.
1703 Regardless of the value of `float-output-format', a floating point number
1704 will never be printed in such a way that it is ambiguous with an integer;
1705 that is, a floating-point number will always be printed with a decimal
1706 point and/or an exponent, even if the digits following the decimal point
1707 are all zero. This is to preserve read-equivalence.
1709 Vfloat_output_format = Qnil;
1710 #endif /* LISP_FLOAT_TYPE */
1712 DEFVAR_LISP ("print-length", &Vprint_length /*
1713 Maximum length of list or vector to print before abbreviating.
1714 A value of nil means no limit.
1716 Vprint_length = Qnil;
1718 DEFVAR_LISP ("print-string-length", &Vprint_string_length /*
1719 Maximum length of string to print before abbreviating.
1720 A value of nil means no limit.
1722 Vprint_string_length = Qnil;
1724 DEFVAR_LISP ("print-level", &Vprint_level /*
1725 Maximum depth of list nesting to print before abbreviating.
1726 A value of nil means no limit.
1728 Vprint_level = Qnil;
1730 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines /*
1731 Non-nil means print newlines in strings as backslash-n.
1733 print_escape_newlines = 0;
1735 DEFVAR_BOOL ("print-readably", &print_readably /*
1736 If non-nil, then all objects will be printed in a readable form.
1737 If an object has no readable representation, then an error is signalled.
1738 When print-readably is true, compiled-function objects will be written in
1739 #[...] form instead of in #<compiled-function [...]> form, and two-element
1740 lists of the form (quote object) will be written as the equivalent 'object.
1741 Do not SET this variable; bind it instead.
1745 /* #### I think this should default to t. But we'd better wait
1746 until we see that it works out. */
1747 DEFVAR_LISP ("print-gensym", &Vprint_gensym /*
1748 If non-nil, then uninterned symbols will be printed specially.
1749 Uninterned symbols are those which are not present in `obarray', that is,
1750 those which were made with `make-symbol' or by calling `intern' with a
1753 When print-gensym is true, such symbols will be preceded by "#:",
1754 which causes the reader to create a new symbol instead of interning
1755 and returning an existing one. Beware: the #: syntax creates a new
1756 symbol each time it is seen, so if you print an object which contains
1757 two pointers to the same uninterned symbol, `read' will not duplicate
1760 If the value of `print-gensym' is a cons cell, then in addition
1761 refrain from clearing `print-gensym-alist' on entry to and exit from
1762 printing functions, so that the use of #...# and #...= can carry over
1763 for several separately printed objects.
1765 Vprint_gensym = Qnil;
1767 DEFVAR_LISP ("print-gensym-alist", &Vprint_gensym_alist /*
1768 Association list of elements (GENSYM . N) to guide use of #N# and #N=.
1769 In each element, GENSYM is an uninterned symbol that has been associated
1770 with #N= for the specified value of N.
1772 Vprint_gensym_alist = Qnil;
1774 DEFVAR_LISP ("print-message-label", &Vprint_message_label /*
1775 Label for minibuffer messages created with `print'. This should
1776 generally be bound with `let' rather than set. (See `display-message'.)
1778 Vprint_message_label = Qprint;