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 enum external_data_format fmt)
115 CONST Extbyte *extptr;
117 GET_CHARPTR_EXT_DATA_ALLOCA (str + offset, len, fmt, extptr, extlen);
120 fwrite (extptr, 1, extlen, stream);
122 /* Q122442 says that pipes are "treated as files, not as
123 devices", and that this is a feature. Before I found that
124 article, I thought it was a bug. Thanks MS, I feel much
126 if (stream == stdout || stream == stderr)
132 assert (CONSOLE_TTY_P (con));
133 Lstream_write (XLSTREAM (CONSOLE_TTY_DATA (con)->outstream),
136 if (stream == stdout || stream == stderr ||
137 (!stream && CONSOLE_TTY_DATA (con)->is_stdio))
141 fwrite (extptr, 1, extlen, termscript);
144 stdout_needs_newline = (extptr[extlen - 1] != '\n');
148 /* Write a string to the output location specified in FUNCTION.
149 Arguments NONRELOC, RELOC, OFFSET, and LEN are as in
150 buffer_insert_string_1() in insdel.c. */
153 output_string (Lisp_Object function, CONST Bufbyte *nonreloc,
154 Lisp_Object reloc, Bytecount offset, Bytecount len)
156 /* This function can GC */
158 /* We change the value of nonreloc (fetching it from reloc as
159 necessary), but we don't want to pass this changed value on to
160 other functions that take both a nonreloc and a reloc, or things
161 may get confused and an assertion failure in
162 fixup_internal_substring() may get triggered. */
163 CONST Bufbyte *newnonreloc = nonreloc;
164 struct gcpro gcpro1, gcpro2;
166 /* Emacs won't print while GCing, but an external debugger might */
167 if (gc_in_progress) return;
169 /* Perhaps not necessary but probably safer. */
170 GCPRO2 (function, reloc);
172 fixup_internal_substring (newnonreloc, reloc, offset, &len);
175 newnonreloc = XSTRING_DATA (reloc);
177 cclen = bytecount_to_charcount (newnonreloc + offset, len);
179 if (LSTREAMP (function))
183 /* Protect against Lstream_write() causing a GC and
184 relocating the string. For small strings, we do it by
185 alloc'ing the string and using a copy; for large strings,
189 Bufbyte *copied = alloca_array (Bufbyte, len);
190 memcpy (copied, newnonreloc + offset, len);
191 Lstream_write (XLSTREAM (function), copied, len);
195 int speccount = specpdl_depth ();
196 record_unwind_protect (restore_gc_inhibit,
197 make_int (gc_currently_forbidden));
198 gc_currently_forbidden = 1;
199 Lstream_write (XLSTREAM (function), newnonreloc + offset, len);
200 unbind_to (speccount, Qnil);
204 Lstream_write (XLSTREAM (function), newnonreloc + offset, len);
206 if (print_unbuffered)
207 Lstream_flush (XLSTREAM (function));
209 else if (BUFFERP (function))
211 CHECK_LIVE_BUFFER (function);
212 buffer_insert_string (XBUFFER (function), nonreloc, reloc, offset, len);
214 else if (MARKERP (function))
216 /* marker_position() will err if marker doesn't point anywhere. */
217 Bufpos spoint = marker_position (function);
219 buffer_insert_string_1 (XMARKER (function)->buffer,
220 spoint, nonreloc, reloc, offset, len,
222 Fset_marker (function, make_int (spoint + cclen),
223 Fmarker_buffer (function));
225 else if (FRAMEP (function))
227 /* This gets used by functions not invoking print_prepare(),
228 such as Fwrite_char, Fterpri, etc.. */
229 struct frame *f = XFRAME (function);
230 CHECK_LIVE_FRAME (function);
232 if (!EQ (Vprint_message_label, echo_area_status (f)))
233 clear_echo_area_from_print (f, Qnil, 1);
234 echo_area_append (f, nonreloc, reloc, offset, len, Vprint_message_label);
236 else if (EQ (function, Qt) || EQ (function, Qnil))
238 write_string_to_stdio_stream (stdout, 0, newnonreloc, offset, len,
243 Charcount ccoff = bytecount_to_charcount (newnonreloc, offset);
246 for (iii = ccoff; iii < cclen + ccoff; iii++)
249 make_char (charptr_emchar_n (newnonreloc, iii)));
251 newnonreloc = XSTRING_DATA (reloc);
258 #define RESET_PRINT_GENSYM do { \
259 if (!CONSP (Vprint_gensym)) \
260 Vprint_gensym_alist = Qnil; \
264 canonicalize_printcharfun (Lisp_Object printcharfun)
266 if (NILP (printcharfun))
267 printcharfun = Vstandard_output;
269 if (EQ (printcharfun, Qt) || NILP (printcharfun))
270 printcharfun = Fselected_frame (Qnil); /* print to minibuffer */
276 print_prepare (Lisp_Object printcharfun, Lisp_Object *frame_kludge)
278 /* Emacs won't print while GCing, but an external debugger might */
284 printcharfun = canonicalize_printcharfun (printcharfun);
286 /* Here we could safely return the canonicalized PRINTCHARFUN.
287 However, if PRINTCHARFUN is a frame, printing of complex
288 structures becomes very expensive, because `append-message'
289 (called by echo_area_append) gets called as many times as
290 output_string() is called (and that's a *lot*). append-message
291 tries to keep top of the message-stack in sync with the contents
292 of " *Echo Area" buffer, consing a new string for each component
293 of the printed structure. For instance, if you print (a a),
294 append-message will cons up the following strings:
302 and will use only the last one. With larger objects, this turns
303 into an O(n^2) consing frenzy that locks up XEmacs in incessant
306 We prevent this by creating a resizing_buffer stream and letting
307 the printer write into it. print_finish() will notice this
308 stream, and invoke echo_area_append() with the stream's buffer,
310 if (FRAMEP (printcharfun))
312 CHECK_LIVE_FRAME (printcharfun);
313 *frame_kludge = printcharfun;
314 printcharfun = make_resizing_buffer_output_stream ();
321 print_finish (Lisp_Object stream, Lisp_Object frame_kludge)
323 /* Emacs won't print while GCing, but an external debugger might */
329 /* See the comment in print_prepare(). */
330 if (FRAMEP (frame_kludge))
332 struct frame *f = XFRAME (frame_kludge);
333 Lstream *str = XLSTREAM (stream);
334 CHECK_LIVE_FRAME (frame_kludge);
337 if (!EQ (Vprint_message_label, echo_area_status (f)))
338 clear_echo_area_from_print (f, Qnil, 1);
339 echo_area_append (f, resizing_buffer_stream_ptr (str),
340 Qnil, 0, Lstream_byte_count (str),
341 Vprint_message_label);
342 Lstream_delete (str);
346 /* Used for printing a single-byte character (*not* any Emchar). */
347 #define write_char_internal(string_of_length_1, stream) \
348 output_string (stream, (CONST Bufbyte *) (string_of_length_1), \
351 /* NOTE: Do not call this with the data of a Lisp_String, as
352 printcharfun might cause a GC, which might cause the string's data
353 to be relocated. To princ a Lisp string, use:
355 print_internal (string, printcharfun, 0);
357 Also note that STREAM should be the result of
358 canonicalize_printcharfun() (i.e. Qnil means stdout, not
359 Vstandard_output, etc.) */
361 write_string_1 (CONST Bufbyte *str, Bytecount size, Lisp_Object stream)
363 /* This function can GC */
364 #ifdef ERROR_CHECK_BUFPOS
367 output_string (stream, str, Qnil, 0, size);
371 write_c_string (CONST char *str, Lisp_Object stream)
373 /* This function can GC */
374 write_string_1 ((CONST Bufbyte *) str, strlen (str), stream);
378 DEFUN ("write-char", Fwrite_char, 1, 2, 0, /*
379 Output character CH to stream STREAM.
380 STREAM defaults to the value of `standard-output' (which see).
384 /* This function can GC */
385 Bufbyte str[MAX_EMCHAR_LEN];
388 CHECK_CHAR_COERCE_INT (ch);
389 len = set_charptr_emchar (str, XCHAR (ch));
390 output_string (canonicalize_printcharfun (stream), str, Qnil, 0, len);
395 temp_output_buffer_setup (Lisp_Object bufname)
397 /* This function can GC */
398 struct buffer *old = current_buffer;
402 /* #### This function should accept a Lisp_Object instead of a char *,
403 so that proper translation on the buffer name can occur. */
406 Fset_buffer (Fget_buffer_create (bufname));
408 current_buffer->read_only = Qnil;
409 Ferase_buffer (Qnil);
411 XSETBUFFER (buf, current_buffer);
412 specbind (Qstandard_output, buf);
414 set_buffer_internal (old);
418 internal_with_output_to_temp_buffer (Lisp_Object bufname,
419 Lisp_Object (*function) (Lisp_Object arg),
421 Lisp_Object same_frame)
423 int speccount = specpdl_depth ();
424 struct gcpro gcpro1, gcpro2, gcpro3;
425 Lisp_Object buf = Qnil;
427 GCPRO3 (buf, arg, same_frame);
429 temp_output_buffer_setup (bufname);
430 buf = Vstandard_output;
432 arg = (*function) (arg);
434 temp_output_buffer_show (buf, same_frame);
437 return unbind_to (speccount, arg);
440 DEFUN ("with-output-to-temp-buffer", Fwith_output_to_temp_buffer, 1, UNEVALLED, 0, /*
441 Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
442 The buffer is cleared out initially, and marked as unmodified when done.
443 All output done by BODY is inserted in that buffer by default.
444 The buffer is displayed in another window, but not selected.
445 The value of the last form in BODY is returned.
446 If BODY does not finish normally, the buffer BUFNAME is not displayed.
448 If variable `temp-buffer-show-function' is non-nil, call it at the end
449 to get the buffer displayed. It gets one argument, the buffer to display.
453 /* This function can GC */
454 Lisp_Object name = Qnil;
455 int speccount = specpdl_depth ();
456 struct gcpro gcpro1, gcpro2;
457 Lisp_Object val = Qnil;
460 /* #### should set the buffer to be translating. See print_internal(). */
464 name = Feval (XCAR (args));
468 temp_output_buffer_setup (name);
471 val = Fprogn (XCDR (args));
473 temp_output_buffer_show (Vstandard_output, Qnil);
475 return unbind_to (speccount, val);
478 DEFUN ("terpri", Fterpri, 0, 1, 0, /*
479 Output a newline to STREAM.
480 If STREAM is omitted or nil, the value of `standard-output' is used.
484 /* This function can GC */
485 write_char_internal ("\n", canonicalize_printcharfun (stream));
489 DEFUN ("prin1", Fprin1, 1, 2, 0, /*
490 Output the printed representation of OBJECT, any Lisp object.
491 Quoting characters are printed when needed to make output that `read'
492 can handle, whenever this is possible.
493 Output stream is STREAM, or value of `standard-output' (which see).
497 /* This function can GC */
498 Lisp_Object frame = Qnil;
499 struct gcpro gcpro1, gcpro2;
500 GCPRO2 (object, stream);
503 stream = print_prepare (stream, &frame);
504 print_internal (object, stream, 1);
505 print_finish (stream, frame);
511 DEFUN ("prin1-to-string", Fprin1_to_string, 1, 2, 0, /*
512 Return a string containing the printed representation of OBJECT,
513 any Lisp object. Quoting characters are used when needed to make output
514 that `read' can handle, whenever this is possible, unless the optional
515 second argument NOESCAPE is non-nil.
519 /* This function can GC */
520 Lisp_Object result = Qnil;
521 Lisp_Object stream = make_resizing_buffer_output_stream ();
522 Lstream *str = XLSTREAM (stream);
523 /* gcpro OBJECT in case a caller forgot to do so */
524 struct gcpro gcpro1, gcpro2, gcpro3;
525 GCPRO3 (object, stream, result);
529 print_internal (object, stream, NILP (noescape));
533 result = make_string (resizing_buffer_stream_ptr (str),
534 Lstream_byte_count (str));
535 Lstream_delete (str);
539 DEFUN ("princ", Fprinc, 1, 2, 0, /*
540 Output the printed representation of OBJECT, any Lisp object.
541 No quoting characters are used; no delimiters are printed around
542 the contents of strings.
543 Output stream is STREAM, or value of standard-output (which see).
547 /* This function can GC */
548 Lisp_Object frame = Qnil;
549 struct gcpro gcpro1, gcpro2;
551 GCPRO2 (object, stream);
552 stream = print_prepare (stream, &frame);
554 print_internal (object, stream, 0);
555 print_finish (stream, frame);
560 DEFUN ("print", Fprint, 1, 2, 0, /*
561 Output the printed representation of OBJECT, with newlines around it.
562 Quoting characters are printed when needed to make output that `read'
563 can handle, whenever this is possible.
564 Output stream is STREAM, or value of `standard-output' (which see).
568 /* This function can GC */
569 Lisp_Object frame = Qnil;
570 struct gcpro gcpro1, gcpro2;
572 GCPRO2 (object, stream);
573 stream = print_prepare (stream, &frame);
575 write_char_internal ("\n", stream);
576 print_internal (object, stream, 1);
577 write_char_internal ("\n", stream);
578 print_finish (stream, frame);
583 /* Print an error message for the error DATA to STREAM. This is a
584 complete implementation of `display-error', which used to be in
585 Lisp (see prim/cmdloop.el). It was ported to C so it can be used
586 efficiently by Ferror_message_string. Fdisplay_error and
587 Ferror_message_string are trivial wrappers around this function.
589 STREAM should be the result of canonicalize_printcharfun(). */
591 print_error_message (Lisp_Object error_object, Lisp_Object stream)
593 /* This function can GC */
594 Lisp_Object type = Fcar_safe (error_object);
595 Lisp_Object method = Qnil;
598 /* No need to GCPRO anything under the assumption that ERROR_OBJECT
601 if (! (CONSP (error_object) && SYMBOLP (type)
602 && CONSP (Fget (type, Qerror_conditions, Qnil))))
605 tail = XCDR (error_object);
613 tail = Fget (type, Qerror_conditions, Qnil);
616 if (!(CONSP (tail) && SYMBOLP (XCAR (tail))))
618 else if (!NILP (Fget (XCAR (tail), Qdisplay_error, Qnil)))
620 method = Fget (XCAR (tail), Qdisplay_error, Qnil);
629 int speccount = specpdl_depth ();
630 Lisp_Object frame = Qnil;
634 specbind (Qprint_message_label, Qerror);
635 stream = print_prepare (stream, &frame);
637 tail = Fcdr (error_object);
638 if (EQ (type, Qerror))
640 print_internal (Fcar (tail), stream, 0);
645 Lisp_Object errmsg = Fget (type, Qerror_message, Qnil);
647 print_internal (type, stream, 0);
649 print_internal (LISP_GETTEXT (errmsg), stream, 0);
653 write_c_string (first ? ": " : ", ", stream);
654 print_internal (Fcar (tail), stream, 1);
658 print_finish (stream, frame);
660 unbind_to (speccount, Qnil);
668 write_c_string (GETTEXT ("Peculiar error "), stream);
669 print_internal (error_object, stream, 1);
674 call2 (method, error_object, stream);
678 DEFUN ("error-message-string", Ferror_message_string, 1, 1, 0, /*
679 Convert ERROR-OBJECT to an error message, and return it.
681 The format of ERROR-OBJECT should be (ERROR-SYMBOL . DATA). The
682 message is equivalent to the one that would be issued by
683 `display-error' with the same argument.
687 /* This function can GC */
688 Lisp_Object result = Qnil;
689 Lisp_Object stream = make_resizing_buffer_output_stream ();
693 print_error_message (error_object, stream);
694 Lstream_flush (XLSTREAM (stream));
695 result = make_string (resizing_buffer_stream_ptr (XLSTREAM (stream)),
696 Lstream_byte_count (XLSTREAM (stream)));
697 Lstream_delete (XLSTREAM (stream));
703 DEFUN ("display-error", Fdisplay_error, 2, 2, 0, /*
704 Display ERROR-OBJECT on STREAM in a user-friendly way.
706 (error_object, stream))
708 /* This function can GC */
709 print_error_message (error_object, canonicalize_printcharfun (stream));
714 #ifdef LISP_FLOAT_TYPE
716 Lisp_Object Vfloat_output_format;
719 * This buffer should be at least as large as the max string size of the
720 * largest float, printed in the biggest notation. This is undoubtably
721 * 20d float_output_format, with the negative of the C-constant "HUGE"
724 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
726 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
727 * case of -1e307 in 20d float_output_format. What is one to do (short of
728 * re-writing _doprnt to be more sane)?
732 float_to_string (char *buf, double data)
737 if (NILP (Vfloat_output_format)
738 || !STRINGP (Vfloat_output_format))
740 sprintf (buf, "%.16g", data);
743 /* Check that the spec we have is fully valid.
744 This means not only valid for printf,
745 but meant for floats, and reasonable. */
746 cp = XSTRING_DATA (Vfloat_output_format);
754 for (width = 0; (c = *cp, isdigit (c)); cp++)
760 if (*cp != 'e' && *cp != 'f' && *cp != 'g' && *cp != 'E' && *cp != 'G')
763 if (width < (int) (*cp != 'e' && *cp != 'E') || width > DBL_DIG)
769 sprintf (buf, (char *) XSTRING_DATA (Vfloat_output_format),
773 /* added by jwz: don't allow "1.0" to print as "1"; that destroys
774 the read-equivalence of lisp objects. (* x 1) and (* x 1.0) do
775 not do the same thing, so it's important that the printed
776 representation of that form not be corrupted by the printer.
779 Bufbyte *s = (Bufbyte *) buf; /* don't use signed chars here!
780 isdigit() can't hack them! */
783 /* if there's a non-digit, then there is a decimal point, or
784 it's in exponential notation, both of which are ok. */
787 /* otherwise, we need to hack it. */
794 /* Some machines print "0.4" as ".4". I don't like that. */
795 if (buf [0] == '.' || (buf [0] == '-' && buf [1] == '.'))
798 for (i = strlen (buf) + 1; i >= 0; i--)
800 buf [(buf [0] == '-' ? 1 : 0)] = '0';
803 #endif /* LISP_FLOAT_TYPE */
805 /* Print NUMBER to BUFFER. The digits are first written in reverse
806 order (the least significant digit first), and are then reversed.
807 This is equivalent to sprintf(buffer, "%ld", number), only much
810 BUFFER should accept 24 bytes. This should suffice for the longest
811 numbers on 64-bit machines, including the `-' sign and the trailing
814 long_to_string (char *buffer, long number)
816 #if (SIZEOF_LONG != 4) && (SIZEOF_LONG != 8)
818 sprintf (buffer, "%ld", number);
819 #else /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
829 #define FROB(figure) do { \
830 if (force || number >= figure) \
831 *p++ = number / figure + '0', number %= figure, force = 1; \
834 FROB (1000000000000000000L);
835 FROB (100000000000000000L);
836 FROB (10000000000000000L);
837 FROB (1000000000000000L);
838 FROB (100000000000000L);
839 FROB (10000000000000L);
840 FROB (1000000000000L);
841 FROB (100000000000L);
843 #endif /* SIZEOF_LONG == 8 */
856 #endif /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
860 print_vector_internal (CONST char *start, CONST char *end,
862 Lisp_Object printcharfun, int escapeflag)
864 /* This function can GC */
866 int len = XVECTOR_LENGTH (obj);
868 struct gcpro gcpro1, gcpro2;
869 GCPRO2 (obj, printcharfun);
871 if (INTP (Vprint_length))
873 int max = XINT (Vprint_length);
874 if (max < len) last = max;
877 write_c_string (start, printcharfun);
878 for (i = 0; i < last; i++)
880 Lisp_Object elt = XVECTOR_DATA (obj)[i];
881 if (i != 0) write_char_internal (" ", printcharfun);
882 print_internal (elt, printcharfun, escapeflag);
886 write_c_string (" ...", printcharfun);
887 write_c_string (end, printcharfun);
891 print_cons (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
893 /* This function can GC */
894 struct gcpro gcpro1, gcpro2;
896 /* If print_readably is on, print (quote -foo-) as '-foo-
897 (Yeah, this should really be what print-pretty does, but we
898 don't have the rest of a pretty printer, and this actually
899 has non-negligible impact on size/speed of .elc files.)
901 if (print_readably &&
902 EQ (XCAR (obj), Qquote) &&
903 CONSP (XCDR (obj)) &&
904 NILP (XCDR (XCDR (obj))))
906 obj = XCAR (XCDR (obj));
907 GCPRO2 (obj, printcharfun);
908 write_char_internal ("\'", printcharfun);
910 print_internal (obj, printcharfun, escapeflag);
914 GCPRO2 (obj, printcharfun);
915 write_char_internal ("(", printcharfun);
919 int max = INTP (Vprint_length) ? XINT (Vprint_length) : INT_MAX;
920 Lisp_Object tortoise;
921 /* Use tortoise/hare to make sure circular lists don't infloop */
923 for (tortoise = obj, len = 0;
925 obj = XCDR (obj), len++)
928 write_char_internal (" ", printcharfun);
929 if (EQ (obj, tortoise) && len > 0)
932 error ("printing unreadable circular list");
934 write_c_string ("... <circular list>", printcharfun);
938 tortoise = XCDR (tortoise);
941 write_c_string ("...", printcharfun);
944 print_internal (XCAR (obj), printcharfun, escapeflag);
949 write_c_string (" . ", printcharfun);
950 print_internal (obj, printcharfun, escapeflag);
954 write_char_internal (")", printcharfun);
959 print_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
961 print_vector_internal ("[", "]", obj, printcharfun, escapeflag);
965 print_string (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
967 struct Lisp_String *s = XSTRING (obj);
968 /* We distinguish between Bytecounts and Charcounts, to make
969 Vprint_string_length work correctly under Mule. */
970 Charcount size = string_char_length (s);
971 Charcount max = size;
972 Bytecount bcmax = string_length (s);
973 struct gcpro gcpro1, gcpro2;
974 GCPRO2 (obj, printcharfun);
976 if (INTP (Vprint_string_length) &&
977 XINT (Vprint_string_length) < max)
979 max = XINT (Vprint_string_length);
980 bcmax = charcount_to_bytecount (string_data (s), max);
990 /* This deals with GC-relocation and Mule. */
991 output_string (printcharfun, 0, obj, 0, bcmax);
993 write_c_string (" ...", printcharfun);
997 Bytecount i, last = 0;
999 write_char_internal ("\"", printcharfun);
1000 for (i = 0; i < bcmax; i++)
1002 Bufbyte ch = string_byte (s, i);
1003 if (ch == '\"' || ch == '\\'
1004 || (ch == '\n' && print_escape_newlines))
1008 output_string (printcharfun, 0, obj, last,
1013 write_c_string ("\\n", printcharfun);
1017 write_char_internal ("\\", printcharfun);
1018 /* This is correct for Mule because the
1019 character is either \ or " */
1020 write_char_internal (string_data (s) + i, printcharfun);
1027 output_string (printcharfun, 0, obj, last,
1031 write_c_string (" ...", printcharfun);
1032 write_char_internal ("\"", printcharfun);
1038 default_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
1041 struct lcrecord_header *header =
1042 (struct lcrecord_header *) XPNTR (obj);
1046 error ("printing unreadable object #<%s 0x%x>",
1047 LHEADER_IMPLEMENTATION (&header->lheader)->name,
1050 sprintf (buf, "#<%s 0x%x>",
1051 LHEADER_IMPLEMENTATION (&header->lheader)->name,
1053 write_c_string (buf, printcharfun);
1057 internal_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
1061 sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%lx>",
1062 XRECORD_LHEADER_IMPLEMENTATION (obj)->name,
1063 (unsigned long) XPNTR (obj));
1064 write_c_string (buf, printcharfun);
1068 print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1070 /* This function can GC */
1074 /* Emacs won't print while GCing, but an external debugger might */
1075 if (gc_in_progress) return;
1078 /* #### Both input and output streams should have a flag associated
1079 with them indicating whether output to that stream, or strings
1080 read from the stream, get translated using Fgettext(). Such a
1081 stream is called a "translating stream". For the minibuffer and
1082 external-debugging-output this is always true on output, and
1083 with-output-to-temp-buffer sets the flag to true for the buffer
1084 it creates. This flag should also be user-settable. Perhaps it
1085 should be split up into two flags, one for input and one for
1089 /* Detect circularities and truncate them.
1090 No need to offer any alternative--this is better than an error. */
1091 if (CONSP (obj) || VECTORP (obj) || COMPILED_FUNCTIONP (obj))
1094 for (i = 0; i < print_depth; i++)
1095 if (EQ (obj, being_printed[i]))
1099 long_to_string (buf + 1, i);
1100 write_c_string (buf, printcharfun);
1105 being_printed[print_depth] = obj;
1108 if (print_depth > PRINT_CIRCLE)
1109 error ("Apparently circular structure being printed");
1111 switch (XTYPE (obj))
1113 case Lisp_Type_Int_Even:
1114 case Lisp_Type_Int_Odd:
1116 /* ASCII Decimal representation uses 2.4 times as many bits as
1118 char buf[3 * sizeof (EMACS_INT) + 5];
1119 long_to_string (buf, XINT (obj));
1120 write_c_string (buf, printcharfun);
1124 case Lisp_Type_Char:
1126 /* God intended that this be #\..., you know. */
1128 Emchar ch = XCHAR (obj);
1136 case '\t': *p++ = 't'; break;
1137 case '\n': *p++ = 'n'; break;
1138 case '\r': *p++ = 'r'; break;
1142 if ((ch + 64) == '\\')
1149 /* syntactically special characters should be escaped. */
1172 *p++ = '\\', *p++ = '^', *p++ = '?';
1176 *p++ = '\\', *p++ = '^';
1177 p += set_charptr_emchar ((Bufbyte *) p, ch + 64);
1181 p += set_charptr_emchar ((Bufbyte *) p, ch);
1184 output_string (printcharfun, (Bufbyte *) buf, Qnil, 0, p - buf);
1189 case Lisp_Type_Record:
1191 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
1192 struct gcpro gcpro1, gcpro2;
1194 if (CONSP (obj) || VECTORP(obj))
1196 /* If deeper than spec'd depth, print placeholder. */
1197 if (INTP (Vprint_level)
1198 && print_depth > XINT (Vprint_level))
1200 GCPRO2 (obj, printcharfun);
1201 write_c_string ("...", printcharfun);
1207 GCPRO2 (obj, printcharfun);
1208 if (LHEADER_IMPLEMENTATION (lheader)->printer)
1209 ((LHEADER_IMPLEMENTATION (lheader)->printer)
1210 (obj, printcharfun, escapeflag));
1212 default_object_printer (obj, printcharfun, escapeflag);
1219 #ifdef ERROR_CHECK_TYPECHECK
1221 #else /* not ERROR_CHECK_TYPECHECK */
1223 /* We're in trouble if this happens! */
1225 error ("printing illegal data type #o%03o",
1227 write_c_string ("#<EMACS BUG: ILLEGAL DATATYPE ",
1229 sprintf (buf, "(#o%3o)", (int) XTYPE (obj));
1230 write_c_string (buf, printcharfun);
1232 (" Save your buffers immediately and please report this bug>",
1234 #endif /* not ERROR_CHECK_TYPECHECK */
1243 #ifdef LISP_FLOAT_TYPE
1245 print_float (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1247 char pigbuf[350]; /* see comments in float_to_string */
1249 float_to_string (pigbuf, XFLOAT_DATA (obj));
1250 write_c_string (pigbuf, printcharfun);
1252 #endif /* LISP_FLOAT_TYPE */
1255 print_symbol (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1257 /* This function can GC */
1258 /* #### Bug!! (intern "") isn't printed in some distinguished way */
1259 /* #### (the reader also loses on it) */
1260 struct Lisp_String *name = symbol_name (XSYMBOL (obj));
1261 Bytecount size = string_length (name);
1262 struct gcpro gcpro1, gcpro2;
1266 /* This deals with GC-relocation */
1267 Lisp_Object nameobj;
1268 XSETSTRING (nameobj, name);
1269 output_string (printcharfun, 0, nameobj, 0, size);
1272 GCPRO2 (obj, printcharfun);
1274 /* If we print an uninterned symbol as part of a complex object and
1275 the flag print-gensym is non-nil, prefix it with #n= to read the
1276 object back with the #n# reader syntax later if needed. */
1277 if (!NILP (Vprint_gensym)
1278 /* #### Test whether this produces a noticable slow-down for
1279 printing when print-gensym is non-nil. */
1280 && !EQ (obj, oblookup (Vobarray,
1281 string_data (symbol_name (XSYMBOL (obj))),
1282 string_length (symbol_name (XSYMBOL (obj))))))
1284 if (print_depth > 1)
1286 Lisp_Object tem = Fassq (obj, Vprint_gensym_alist);
1289 write_char_internal ("#", printcharfun);
1290 print_internal (XCDR (tem), printcharfun, escapeflag);
1291 write_char_internal ("#", printcharfun);
1296 if (CONSP (Vprint_gensym_alist))
1298 /* Vprint_gensym_alist is exposed to Lisp, so we
1299 have to be careful. */
1300 CHECK_CONS (XCAR (Vprint_gensym_alist));
1301 CHECK_INT (XCDR (XCAR (Vprint_gensym_alist)));
1302 XSETINT (tem, XINT (XCDR (XCAR (Vprint_gensym_alist))) + 1);
1306 Vprint_gensym_alist = Fcons (Fcons (obj, tem), Vprint_gensym_alist);
1308 write_char_internal ("#", printcharfun);
1309 print_internal (tem, printcharfun, escapeflag);
1310 write_char_internal ("=", printcharfun);
1313 write_c_string ("#:", printcharfun);
1316 /* Does it look like an integer or a float? */
1318 Bufbyte *data = string_data (name);
1319 Bytecount confusing = 0;
1322 goto not_yet_confused; /* Really confusing */
1323 else if (isdigit (data[0]))
1326 goto not_yet_confused;
1327 else if (data[0] == '-' || data[0] == '+')
1330 goto not_yet_confused;
1332 for (; confusing < size; confusing++)
1334 if (!isdigit (data[confusing]))
1342 #ifdef LISP_FLOAT_TYPE
1344 /* #### Ugh, this is needlessly complex and slow for what we
1345 need here. It might be a good idea to copy equivalent code
1346 from FSF. --hniksic */
1347 confusing = isfloat_string ((char *) data);
1350 write_char_internal ("\\", printcharfun);
1354 Lisp_Object nameobj;
1358 XSETSTRING (nameobj, name);
1359 for (i = 0; i < size; i++)
1361 switch (string_byte (name, i))
1363 case 0: case 1: case 2: case 3:
1364 case 4: case 5: case 6: case 7:
1365 case 8: case 9: case 10: case 11:
1366 case 12: case 13: case 14: case 15:
1367 case 16: case 17: case 18: case 19:
1368 case 20: case 21: case 22: case 23:
1369 case 24: case 25: case 26: case 27:
1370 case 28: case 29: case 30: case 31:
1371 case ' ': case '\"': case '\\': case '\'':
1372 case ';': case '#' : case '(' : case ')':
1373 case ',': case '.' : case '`' :
1374 case '[': case ']' : case '?' :
1376 output_string (printcharfun, 0, nameobj, last, i - last);
1377 write_char_internal ("\\", printcharfun);
1381 output_string (printcharfun, 0, nameobj, last, size - last);
1386 /* #ifdef DEBUG_XEMACS */
1388 /* I don't like seeing `Note: Strange doc (not fboundp) for function
1389 alternate-debugging-output @ 429542' -slb */
1390 /* #### Eek! Any clue how to get rid of it? In fact, how about
1391 getting rid of this function altogether? Does anything actually
1392 *use* it? --hniksic */
1394 static int alternate_do_pointer;
1395 static char alternate_do_string[5000];
1397 DEFUN ("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0, /*
1398 Append CHARACTER to the array `alternate_do_string'.
1399 This can be used in place of `external-debugging-output' as a function
1400 to be passed to `print'. Before calling `print', set `alternate_do_pointer'
1405 Bufbyte str[MAX_EMCHAR_LEN];
1408 CONST Extbyte *extptr;
1410 CHECK_CHAR_COERCE_INT (character);
1411 len = set_charptr_emchar (str, XCHAR (character));
1412 GET_CHARPTR_EXT_DATA_ALLOCA (str, len, FORMAT_TERMINAL, extptr, extlen);
1413 memcpy (alternate_do_string + alternate_do_pointer, extptr, extlen);
1414 alternate_do_pointer += extlen;
1415 alternate_do_string[alternate_do_pointer] = 0;
1418 /* #endif / * DEBUG_XEMACS */
1420 DEFUN ("external-debugging-output", Fexternal_debugging_output, 1, 3, 0, /*
1421 Write CHAR-OR-STRING to stderr or stdout.
1422 If optional arg STDOUT-P is non-nil, write to stdout; otherwise, write
1423 to stderr. You can use this function to write directly to the terminal.
1424 This function can be used as the STREAM argument of Fprint() or the like.
1426 If you have opened a termscript file (using `open-termscript'), then
1427 the output also will be logged to this file.
1429 (char_or_string, stdout_p, device))
1432 struct console *con = 0;
1436 if (!NILP (stdout_p))
1443 CHECK_LIVE_DEVICE (device);
1444 if (!DEVICE_TTY_P (XDEVICE (device)) &&
1445 !DEVICE_STREAM_P (XDEVICE (device)))
1446 signal_simple_error ("Must be tty or stream device", device);
1447 con = XCONSOLE (DEVICE_CONSOLE (XDEVICE (device)));
1448 if (DEVICE_TTY_P (XDEVICE (device)))
1450 else if (!NILP (stdout_p))
1451 file = CONSOLE_STREAM_DATA (con)->out;
1453 file = CONSOLE_STREAM_DATA (con)->err;
1456 if (STRINGP (char_or_string))
1457 write_string_to_stdio_stream (file, con,
1458 XSTRING_DATA (char_or_string),
1459 0, XSTRING_LENGTH (char_or_string),
1463 Bufbyte str[MAX_EMCHAR_LEN];
1466 CHECK_CHAR_COERCE_INT (char_or_string);
1467 len = set_charptr_emchar (str, XCHAR (char_or_string));
1468 write_string_to_stdio_stream (file, con, str, 0, len, FORMAT_TERMINAL);
1471 return char_or_string;
1474 DEFUN ("open-termscript", Fopen_termscript, 1, 1, "FOpen termscript file: ", /*
1475 Start writing all terminal output to FILE as well as the terminal.
1476 FILE = nil means just close any termscript file currently open.
1480 /* This function can GC */
1481 if (termscript != 0)
1482 fclose (termscript);
1487 file = Fexpand_file_name (file, Qnil);
1488 termscript = fopen ((char *) XSTRING_DATA (file), "w");
1489 if (termscript == NULL)
1490 report_file_error ("Opening termscript", list1 (file));
1496 /* Debugging kludge -- unbuffered */
1497 static int debug_print_length = 50;
1498 static int debug_print_level = 15;
1501 debug_print_no_newline (Lisp_Object debug_print_obj)
1503 /* This function can GC */
1504 int old_print_readably = print_readably;
1505 int old_print_depth = print_depth;
1506 Lisp_Object old_print_length = Vprint_length;
1507 Lisp_Object old_print_level = Vprint_level;
1508 Lisp_Object old_inhibit_quit = Vinhibit_quit;
1509 struct gcpro gcpro1, gcpro2, gcpro3;
1510 GCPRO3 (old_print_level, old_print_length, old_inhibit_quit);
1513 stderr_out ("** gc-in-progress! Bad idea to print anything! **\n");
1518 /* Could use unwind-protect, but why bother? */
1519 if (debug_print_length > 0)
1520 Vprint_length = make_int (debug_print_length);
1521 if (debug_print_level > 0)
1522 Vprint_level = make_int (debug_print_level);
1523 print_internal (debug_print_obj, Qexternal_debugging_output, 1);
1524 Vinhibit_quit = old_inhibit_quit;
1525 Vprint_level = old_print_level;
1526 Vprint_length = old_print_length;
1527 print_depth = old_print_depth;
1528 print_readably = old_print_readably;
1534 debug_print (Lisp_Object debug_print_obj)
1536 debug_print_no_newline (debug_print_obj);
1541 /* Debugging kludge -- unbuffered */
1542 /* This function provided for the benefit of the debugger. */
1543 void debug_backtrace (void);
1545 debug_backtrace (void)
1547 /* This function can GC */
1548 int old_print_readably = print_readably;
1549 int old_print_depth = print_depth;
1550 Lisp_Object old_print_length = Vprint_length;
1551 Lisp_Object old_print_level = Vprint_level;
1552 Lisp_Object old_inhibit_quit = Vinhibit_quit;
1554 struct gcpro gcpro1, gcpro2, gcpro3;
1555 GCPRO3 (old_print_level, old_print_length, old_inhibit_quit);
1558 stderr_out ("** gc-in-progress! Bad idea to print anything! **\n");
1563 /* Could use unwind-protect, but why bother? */
1564 if (debug_print_length > 0)
1565 Vprint_length = make_int (debug_print_length);
1566 if (debug_print_level > 0)
1567 Vprint_level = make_int (debug_print_level);
1569 Fbacktrace (Qexternal_debugging_output, Qt);
1573 Vinhibit_quit = old_inhibit_quit;
1574 Vprint_level = old_print_level;
1575 Vprint_length = old_print_length;
1576 print_depth = old_print_depth;
1577 print_readably = old_print_readably;
1584 debug_short_backtrace (int length)
1587 struct backtrace *bt = backtrace_list;
1590 while (length > 0 && bt)
1597 if (COMPILED_FUNCTIONP (*bt->function))
1599 #if defined(COMPILED_FUNCTION_ANNOTATION_HACK)
1601 compiled_function_annotation (XCOMPILED_FUNCTION (*bt->function));
1603 Lisp_Object ann = Qnil;
1607 stderr_out ("<compiled-function from ");
1609 debug_print_no_newline (ann);
1615 stderr_out ("<compiled-function of unknown origin>");
1620 debug_print_no_newline (*bt->function);
1629 #endif /* debugging kludge */
1633 syms_of_print (void)
1635 defsymbol (&Qstandard_output, "standard-output");
1637 defsymbol (&Qprint_length, "print-length");
1639 defsymbol (&Qprint_string_length, "print-string-length");
1641 defsymbol (&Qdisplay_error, "display-error");
1642 defsymbol (&Qprint_message_label, "print-message-label");
1645 DEFSUBR (Fprin1_to_string);
1648 DEFSUBR (Ferror_message_string);
1649 DEFSUBR (Fdisplay_error);
1651 DEFSUBR (Fwrite_char);
1652 DEFSUBR (Falternate_debugging_output);
1653 DEFSUBR (Fexternal_debugging_output);
1654 DEFSUBR (Fopen_termscript);
1655 defsymbol (&Qexternal_debugging_output, "external-debugging-output");
1656 DEFSUBR (Fwith_output_to_temp_buffer);
1660 reinit_vars_of_print (void)
1662 alternate_do_pointer = 0;
1666 vars_of_print (void)
1668 reinit_vars_of_print ();
1670 DEFVAR_LISP ("standard-output", &Vstandard_output /*
1671 Output stream `print' uses by default for outputting a character.
1672 This may be any function of one argument.
1673 It may also be a buffer (output is inserted before point)
1674 or a marker (output is inserted and the marker is advanced)
1675 or the symbol t (output appears in the minibuffer line).
1677 Vstandard_output = Qt;
1679 #ifdef LISP_FLOAT_TYPE
1680 DEFVAR_LISP ("float-output-format", &Vfloat_output_format /*
1681 The format descriptor string that lisp uses to print floats.
1682 This is a %-spec like those accepted by `printf' in C,
1683 but with some restrictions. It must start with the two characters `%.'.
1684 After that comes an integer precision specification,
1685 and then a letter which controls the format.
1686 The letters allowed are `e', `f' and `g'.
1687 Use `e' for exponential notation "DIG.DIGITSeEXPT"
1688 Use `f' for decimal point notation "DIGITS.DIGITS".
1689 Use `g' to choose the shorter of those two formats for the number at hand.
1690 The precision in any of these cases is the number of digits following
1691 the decimal point. With `f', a precision of 0 means to omit the
1692 decimal point. 0 is not allowed with `f' or `g'.
1694 A value of nil means to use `%.16g'.
1696 Regardless of the value of `float-output-format', a floating point number
1697 will never be printed in such a way that it is ambiguous with an integer;
1698 that is, a floating-point number will always be printed with a decimal
1699 point and/or an exponent, even if the digits following the decimal point
1700 are all zero. This is to preserve read-equivalence.
1702 Vfloat_output_format = Qnil;
1703 #endif /* LISP_FLOAT_TYPE */
1705 DEFVAR_LISP ("print-length", &Vprint_length /*
1706 Maximum length of list or vector to print before abbreviating.
1707 A value of nil means no limit.
1709 Vprint_length = Qnil;
1711 DEFVAR_LISP ("print-string-length", &Vprint_string_length /*
1712 Maximum length of string to print before abbreviating.
1713 A value of nil means no limit.
1715 Vprint_string_length = Qnil;
1717 DEFVAR_LISP ("print-level", &Vprint_level /*
1718 Maximum depth of list nesting to print before abbreviating.
1719 A value of nil means no limit.
1721 Vprint_level = Qnil;
1723 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines /*
1724 Non-nil means print newlines in strings as backslash-n.
1726 print_escape_newlines = 0;
1728 DEFVAR_BOOL ("print-readably", &print_readably /*
1729 If non-nil, then all objects will be printed in a readable form.
1730 If an object has no readable representation, then an error is signalled.
1731 When print-readably is true, compiled-function objects will be written in
1732 #[...] form instead of in #<compiled-function [...]> form, and two-element
1733 lists of the form (quote object) will be written as the equivalent 'object.
1734 Do not SET this variable; bind it instead.
1738 /* #### I think this should default to t. But we'd better wait
1739 until we see that it works out. */
1740 DEFVAR_LISP ("print-gensym", &Vprint_gensym /*
1741 If non-nil, then uninterned symbols will be printed specially.
1742 Uninterned symbols are those which are not present in `obarray', that is,
1743 those which were made with `make-symbol' or by calling `intern' with a
1746 When print-gensym is true, such symbols will be preceded by "#:",
1747 which causes the reader to create a new symbol instead of interning
1748 and returning an existing one. Beware: the #: syntax creates a new
1749 symbol each time it is seen, so if you print an object which contains
1750 two pointers to the same uninterned symbol, `read' will not duplicate
1753 If the value of `print-gensym' is a cons cell, then in addition
1754 refrain from clearing `print-gensym-alist' on entry to and exit from
1755 printing functions, so that the use of #...# and #...= can carry over
1756 for several separately printed objects.
1758 Vprint_gensym = Qnil;
1760 DEFVAR_LISP ("print-gensym-alist", &Vprint_gensym_alist /*
1761 Association list of elements (GENSYM . N) to guide use of #N# and #N=.
1762 In each element, GENSYM is an uninterned symbol that has been associated
1763 with #N= for the specified value of N.
1765 Vprint_gensym_alist = Qnil;
1767 DEFVAR_LISP ("print-message-label", &Vprint_message_label /*
1768 Label for minibuffer messages created with `print'. This should
1769 generally be bound with `let' rather than set. (See `display-message'.)
1771 Vprint_message_label = Qprint;