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 ();
631 specbind (Qprint_message_label, Qerror);
632 tail = Fcdr (error_object);
633 if (EQ (type, Qerror))
635 print_internal (Fcar (tail), stream, 0);
640 Lisp_Object errmsg = Fget (type, Qerror_message, Qnil);
642 print_internal (type, stream, 0);
644 print_internal (LISP_GETTEXT (errmsg), stream, 0);
648 write_c_string (first ? ": " : ", ", stream);
649 print_internal (Fcar (tail), stream, 1);
653 unbind_to (speccount, Qnil);
661 write_c_string (GETTEXT ("Peculiar error "), stream);
662 print_internal (error_object, stream, 1);
667 call2 (method, error_object, stream);
671 DEFUN ("error-message-string", Ferror_message_string, 1, 1, 0, /*
672 Convert ERROR-OBJECT to an error message, and return it.
674 The format of ERROR-OBJECT should be (ERROR-SYMBOL . DATA). The
675 message is equivalent to the one that would be issued by
676 `display-error' with the same argument.
680 /* This function can GC */
681 Lisp_Object result = Qnil;
682 Lisp_Object stream = make_resizing_buffer_output_stream ();
686 print_error_message (error_object, stream);
687 Lstream_flush (XLSTREAM (stream));
688 result = make_string (resizing_buffer_stream_ptr (XLSTREAM (stream)),
689 Lstream_byte_count (XLSTREAM (stream)));
690 Lstream_delete (XLSTREAM (stream));
696 DEFUN ("display-error", Fdisplay_error, 2, 2, 0, /*
697 Display ERROR-OBJECT on STREAM in a user-friendly way.
699 (error_object, stream))
701 /* This function can GC */
702 print_error_message (error_object, canonicalize_printcharfun (stream));
707 #ifdef LISP_FLOAT_TYPE
709 Lisp_Object Vfloat_output_format;
712 * This buffer should be at least as large as the max string size of the
713 * largest float, printed in the biggest notation. This is undoubtably
714 * 20d float_output_format, with the negative of the C-constant "HUGE"
717 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
719 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
720 * case of -1e307 in 20d float_output_format. What is one to do (short of
721 * re-writing _doprnt to be more sane)?
725 float_to_string (char *buf, double data)
730 if (NILP (Vfloat_output_format)
731 || !STRINGP (Vfloat_output_format))
733 sprintf (buf, "%.16g", data);
736 /* Check that the spec we have is fully valid.
737 This means not only valid for printf,
738 but meant for floats, and reasonable. */
739 cp = XSTRING_DATA (Vfloat_output_format);
747 for (width = 0; (c = *cp, isdigit (c)); cp++)
753 if (*cp != 'e' && *cp != 'f' && *cp != 'g' && *cp != 'E' && *cp != 'G')
756 if (width < (int) (*cp != 'e' && *cp != 'E') || width > DBL_DIG)
762 sprintf (buf, (char *) XSTRING_DATA (Vfloat_output_format),
766 /* added by jwz: don't allow "1.0" to print as "1"; that destroys
767 the read-equivalence of lisp objects. (* x 1) and (* x 1.0) do
768 not do the same thing, so it's important that the printed
769 representation of that form not be corrupted by the printer.
772 Bufbyte *s = (Bufbyte *) buf; /* don't use signed chars here!
773 isdigit() can't hack them! */
776 /* if there's a non-digit, then there is a decimal point, or
777 it's in exponential notation, both of which are ok. */
780 /* otherwise, we need to hack it. */
787 /* Some machines print "0.4" as ".4". I don't like that. */
788 if (buf [0] == '.' || (buf [0] == '-' && buf [1] == '.'))
791 for (i = strlen (buf) + 1; i >= 0; i--)
793 buf [(buf [0] == '-' ? 1 : 0)] = '0';
796 #endif /* LISP_FLOAT_TYPE */
798 /* Print NUMBER to BUFFER. The digits are first written in reverse
799 order (the least significant digit first), and are then reversed.
800 This is equivalent to sprintf(buffer, "%ld", number), only much
803 BUFFER should accept 24 bytes. This should suffice for the longest
804 numbers on 64-bit machines, including the `-' sign and the trailing
807 long_to_string (char *buffer, long number)
809 #if (SIZEOF_LONG != 4) && (SIZEOF_LONG != 8)
811 sprintf (buffer, "%ld", number);
812 #else /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
822 #define FROB(figure) do { \
823 if (force || number >= figure) \
824 *p++ = number / figure + '0', number %= figure, force = 1; \
827 FROB (1000000000000000000L);
828 FROB (100000000000000000L);
829 FROB (10000000000000000L);
830 FROB (1000000000000000L);
831 FROB (100000000000000L);
832 FROB (10000000000000L);
833 FROB (1000000000000L);
834 FROB (100000000000L);
836 #endif /* SIZEOF_LONG == 8 */
849 #endif /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
853 print_vector_internal (CONST char *start, CONST char *end,
855 Lisp_Object printcharfun, int escapeflag)
857 /* This function can GC */
859 int len = XVECTOR_LENGTH (obj);
861 struct gcpro gcpro1, gcpro2;
862 GCPRO2 (obj, printcharfun);
864 if (INTP (Vprint_length))
866 int max = XINT (Vprint_length);
867 if (max < len) last = max;
870 write_c_string (start, printcharfun);
871 for (i = 0; i < last; i++)
873 Lisp_Object elt = XVECTOR_DATA (obj)[i];
874 if (i != 0) write_char_internal (" ", printcharfun);
875 print_internal (elt, printcharfun, escapeflag);
879 write_c_string (" ...", printcharfun);
880 write_c_string (end, printcharfun);
884 print_cons (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
886 /* This function can GC */
887 struct gcpro gcpro1, gcpro2;
889 /* If print_readably is on, print (quote -foo-) as '-foo-
890 (Yeah, this should really be what print-pretty does, but we
891 don't have the rest of a pretty printer, and this actually
892 has non-negligible impact on size/speed of .elc files.)
894 if (print_readably &&
895 EQ (XCAR (obj), Qquote) &&
896 CONSP (XCDR (obj)) &&
897 NILP (XCDR (XCDR (obj))))
899 obj = XCAR (XCDR (obj));
900 GCPRO2 (obj, printcharfun);
901 write_char_internal ("\'", printcharfun);
903 print_internal (obj, printcharfun, escapeflag);
907 GCPRO2 (obj, printcharfun);
908 write_char_internal ("(", printcharfun);
912 int max = INTP (Vprint_length) ? XINT (Vprint_length) : INT_MAX;
913 Lisp_Object tortoise;
914 /* Use tortoise/hare to make sure circular lists don't infloop */
916 for (tortoise = obj, len = 0;
918 obj = XCDR (obj), len++)
921 write_char_internal (" ", printcharfun);
922 if (EQ (obj, tortoise) && len > 0)
925 error ("printing unreadable circular list");
927 write_c_string ("... <circular list>", printcharfun);
931 tortoise = XCDR (tortoise);
934 write_c_string ("...", printcharfun);
937 print_internal (XCAR (obj), printcharfun, escapeflag);
942 write_c_string (" . ", printcharfun);
943 print_internal (obj, printcharfun, escapeflag);
947 write_char_internal (")", printcharfun);
952 print_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
954 print_vector_internal ("[", "]", obj, printcharfun, escapeflag);
958 print_string (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
960 struct Lisp_String *s = XSTRING (obj);
961 /* We distinguish between Bytecounts and Charcounts, to make
962 Vprint_string_length work correctly under Mule. */
963 Charcount size = string_char_length (s);
964 Charcount max = size;
965 Bytecount bcmax = string_length (s);
966 struct gcpro gcpro1, gcpro2;
967 GCPRO2 (obj, printcharfun);
969 if (INTP (Vprint_string_length) &&
970 XINT (Vprint_string_length) < max)
972 max = XINT (Vprint_string_length);
973 bcmax = charcount_to_bytecount (string_data (s), max);
983 /* This deals with GC-relocation and Mule. */
984 output_string (printcharfun, 0, obj, 0, bcmax);
986 write_c_string (" ...", printcharfun);
990 Bytecount i, last = 0;
992 write_char_internal ("\"", printcharfun);
993 for (i = 0; i < bcmax; i++)
995 Bufbyte ch = string_byte (s, i);
996 if (ch == '\"' || ch == '\\'
997 || (ch == '\n' && print_escape_newlines))
1001 output_string (printcharfun, 0, obj, last,
1006 write_c_string ("\\n", printcharfun);
1010 write_char_internal ("\\", printcharfun);
1011 /* This is correct for Mule because the
1012 character is either \ or " */
1013 write_char_internal (string_data (s) + i, printcharfun);
1020 output_string (printcharfun, 0, obj, last,
1024 write_c_string (" ...", printcharfun);
1025 write_char_internal ("\"", printcharfun);
1031 default_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
1034 struct lcrecord_header *header =
1035 (struct lcrecord_header *) XPNTR (obj);
1039 error ("printing unreadable object #<%s 0x%x>",
1040 LHEADER_IMPLEMENTATION (&header->lheader)->name,
1043 sprintf (buf, "#<%s 0x%x>",
1044 LHEADER_IMPLEMENTATION (&header->lheader)->name,
1046 write_c_string (buf, printcharfun);
1050 internal_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
1054 sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%lx>",
1055 XRECORD_LHEADER_IMPLEMENTATION (obj)->name,
1056 (unsigned long) XPNTR (obj));
1057 write_c_string (buf, printcharfun);
1061 print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1063 /* This function can GC */
1067 /* Emacs won't print while GCing, but an external debugger might */
1068 if (gc_in_progress) return;
1071 /* #### Both input and output streams should have a flag associated
1072 with them indicating whether output to that stream, or strings
1073 read from the stream, get translated using Fgettext(). Such a
1074 stream is called a "translating stream". For the minibuffer and
1075 external-debugging-output this is always true on output, and
1076 with-output-to-temp-buffer sets the flag to true for the buffer
1077 it creates. This flag should also be user-settable. Perhaps it
1078 should be split up into two flags, one for input and one for
1082 /* Detect circularities and truncate them.
1083 No need to offer any alternative--this is better than an error. */
1084 if (CONSP (obj) || VECTORP (obj) || COMPILED_FUNCTIONP (obj))
1087 for (i = 0; i < print_depth; i++)
1088 if (EQ (obj, being_printed[i]))
1092 long_to_string (buf + 1, i);
1093 write_c_string (buf, printcharfun);
1098 being_printed[print_depth] = obj;
1101 if (print_depth > PRINT_CIRCLE)
1102 error ("Apparently circular structure being printed");
1104 switch (XTYPE (obj))
1106 case Lisp_Type_Int_Even:
1107 case Lisp_Type_Int_Odd:
1109 /* ASCII Decimal representation uses 2.4 times as many bits as
1111 char buf[3 * sizeof (EMACS_INT) + 5];
1112 long_to_string (buf, XINT (obj));
1113 write_c_string (buf, printcharfun);
1117 case Lisp_Type_Char:
1119 /* God intended that this be #\..., you know. */
1121 Emchar ch = XCHAR (obj);
1129 case '\t': *p++ = 't'; break;
1130 case '\n': *p++ = 'n'; break;
1131 case '\r': *p++ = 'r'; break;
1135 if ((ch + 64) == '\\')
1142 /* syntactically special characters should be escaped. */
1165 *p++ = '\\', *p++ = '^', *p++ = '?';
1169 *p++ = '\\', *p++ = '^';
1170 p += set_charptr_emchar ((Bufbyte *) p, ch + 64);
1174 p += set_charptr_emchar ((Bufbyte *) p, ch);
1177 output_string (printcharfun, (Bufbyte *) buf, Qnil, 0, p - buf);
1182 case Lisp_Type_Record:
1184 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
1185 struct gcpro gcpro1, gcpro2;
1187 if (CONSP (obj) || VECTORP(obj))
1189 /* If deeper than spec'd depth, print placeholder. */
1190 if (INTP (Vprint_level)
1191 && print_depth > XINT (Vprint_level))
1193 GCPRO2 (obj, printcharfun);
1194 write_c_string ("...", printcharfun);
1200 GCPRO2 (obj, printcharfun);
1201 if (LHEADER_IMPLEMENTATION (lheader)->printer)
1202 ((LHEADER_IMPLEMENTATION (lheader)->printer)
1203 (obj, printcharfun, escapeflag));
1205 default_object_printer (obj, printcharfun, escapeflag);
1212 #ifdef ERROR_CHECK_TYPECHECK
1214 #else /* not ERROR_CHECK_TYPECHECK */
1216 /* We're in trouble if this happens! */
1218 error ("printing illegal data type #o%03o",
1220 write_c_string ("#<EMACS BUG: ILLEGAL DATATYPE ",
1222 sprintf (buf, "(#o%3o)", (int) XTYPE (obj));
1223 write_c_string (buf, printcharfun);
1225 (" Save your buffers immediately and please report this bug>",
1227 #endif /* not ERROR_CHECK_TYPECHECK */
1236 #ifdef LISP_FLOAT_TYPE
1238 print_float (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1240 char pigbuf[350]; /* see comments in float_to_string */
1242 float_to_string (pigbuf, XFLOAT_DATA (obj));
1243 write_c_string (pigbuf, printcharfun);
1245 #endif /* LISP_FLOAT_TYPE */
1248 print_symbol (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1250 /* This function can GC */
1251 /* #### Bug!! (intern "") isn't printed in some distinguished way */
1252 /* #### (the reader also loses on it) */
1253 struct Lisp_String *name = symbol_name (XSYMBOL (obj));
1254 Bytecount size = string_length (name);
1255 struct gcpro gcpro1, gcpro2;
1259 /* This deals with GC-relocation */
1260 Lisp_Object nameobj;
1261 XSETSTRING (nameobj, name);
1262 output_string (printcharfun, 0, nameobj, 0, size);
1265 GCPRO2 (obj, printcharfun);
1267 /* If we print an uninterned symbol as part of a complex object and
1268 the flag print-gensym is non-nil, prefix it with #n= to read the
1269 object back with the #n# reader syntax later if needed. */
1270 if (!NILP (Vprint_gensym)
1271 /* #### Test whether this produces a noticable slow-down for
1272 printing when print-gensym is non-nil. */
1273 && !EQ (obj, oblookup (Vobarray,
1274 string_data (symbol_name (XSYMBOL (obj))),
1275 string_length (symbol_name (XSYMBOL (obj))))))
1277 if (print_depth > 1)
1279 Lisp_Object tem = Fassq (obj, Vprint_gensym_alist);
1282 write_char_internal ("#", printcharfun);
1283 print_internal (XCDR (tem), printcharfun, escapeflag);
1284 write_char_internal ("#", printcharfun);
1289 if (CONSP (Vprint_gensym_alist))
1291 /* Vprint_gensym_alist is exposed to Lisp, so we
1292 have to be careful. */
1293 CHECK_CONS (XCAR (Vprint_gensym_alist));
1294 CHECK_INT (XCDR (XCAR (Vprint_gensym_alist)));
1295 XSETINT (tem, XINT (XCDR (XCAR (Vprint_gensym_alist))) + 1);
1299 Vprint_gensym_alist = Fcons (Fcons (obj, tem), Vprint_gensym_alist);
1301 write_char_internal ("#", printcharfun);
1302 print_internal (tem, printcharfun, escapeflag);
1303 write_char_internal ("=", printcharfun);
1306 write_c_string ("#:", printcharfun);
1309 /* Does it look like an integer or a float? */
1311 Bufbyte *data = string_data (name);
1312 Bytecount confusing = 0;
1315 goto not_yet_confused; /* Really confusing */
1316 else if (isdigit (data[0]))
1319 goto not_yet_confused;
1320 else if (data[0] == '-' || data[0] == '+')
1323 goto not_yet_confused;
1325 for (; confusing < size; confusing++)
1327 if (!isdigit (data[confusing]))
1335 #ifdef LISP_FLOAT_TYPE
1337 /* #### Ugh, this is needlessly complex and slow for what we
1338 need here. It might be a good idea to copy equivalent code
1339 from FSF. --hniksic */
1340 confusing = isfloat_string ((char *) data);
1343 write_char_internal ("\\", printcharfun);
1347 Lisp_Object nameobj;
1351 XSETSTRING (nameobj, name);
1352 for (i = 0; i < size; i++)
1354 switch (string_byte (name, i))
1356 case 0: case 1: case 2: case 3:
1357 case 4: case 5: case 6: case 7:
1358 case 8: case 9: case 10: case 11:
1359 case 12: case 13: case 14: case 15:
1360 case 16: case 17: case 18: case 19:
1361 case 20: case 21: case 22: case 23:
1362 case 24: case 25: case 26: case 27:
1363 case 28: case 29: case 30: case 31:
1364 case ' ': case '\"': case '\\': case '\'':
1365 case ';': case '#' : case '(' : case ')':
1366 case ',': case '.' : case '`' :
1367 case '[': case ']' : case '?' :
1369 output_string (printcharfun, 0, nameobj, last, i - last);
1370 write_char_internal ("\\", printcharfun);
1374 output_string (printcharfun, 0, nameobj, last, size - last);
1379 /* #ifdef DEBUG_XEMACS */
1381 /* I don't like seeing `Note: Strange doc (not fboundp) for function
1382 alternate-debugging-output @ 429542' -slb */
1383 /* #### Eek! Any clue how to get rid of it? In fact, how about
1384 getting rid of this function altogether? Does anything actually
1385 *use* it? --hniksic */
1387 static int alternate_do_pointer;
1388 static char alternate_do_string[5000];
1390 DEFUN ("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0, /*
1391 Append CHARACTER to the array `alternate_do_string'.
1392 This can be used in place of `external-debugging-output' as a function
1393 to be passed to `print'. Before calling `print', set `alternate_do_pointer'
1398 Bufbyte str[MAX_EMCHAR_LEN];
1401 CONST Extbyte *extptr;
1403 CHECK_CHAR_COERCE_INT (character);
1404 len = set_charptr_emchar (str, XCHAR (character));
1405 GET_CHARPTR_EXT_DATA_ALLOCA (str, len, FORMAT_TERMINAL, extptr, extlen);
1406 memcpy (alternate_do_string + alternate_do_pointer, extptr, extlen);
1407 alternate_do_pointer += extlen;
1408 alternate_do_string[alternate_do_pointer] = 0;
1411 /* #endif / * DEBUG_XEMACS */
1413 DEFUN ("external-debugging-output", Fexternal_debugging_output, 1, 3, 0, /*
1414 Write CHAR-OR-STRING to stderr or stdout.
1415 If optional arg STDOUT-P is non-nil, write to stdout; otherwise, write
1416 to stderr. You can use this function to write directly to the terminal.
1417 This function can be used as the STREAM argument of Fprint() or the like.
1419 If you have opened a termscript file (using `open-termscript'), then
1420 the output also will be logged to this file.
1422 (char_or_string, stdout_p, device))
1425 struct console *con = 0;
1429 if (!NILP (stdout_p))
1436 CHECK_LIVE_DEVICE (device);
1437 if (!DEVICE_TTY_P (XDEVICE (device)) &&
1438 !DEVICE_STREAM_P (XDEVICE (device)))
1439 signal_simple_error ("Must be tty or stream device", device);
1440 con = XCONSOLE (DEVICE_CONSOLE (XDEVICE (device)));
1441 if (DEVICE_TTY_P (XDEVICE (device)))
1443 else if (!NILP (stdout_p))
1444 file = CONSOLE_STREAM_DATA (con)->out;
1446 file = CONSOLE_STREAM_DATA (con)->err;
1449 if (STRINGP (char_or_string))
1450 write_string_to_stdio_stream (file, con,
1451 XSTRING_DATA (char_or_string),
1452 0, XSTRING_LENGTH (char_or_string),
1456 Bufbyte str[MAX_EMCHAR_LEN];
1459 CHECK_CHAR_COERCE_INT (char_or_string);
1460 len = set_charptr_emchar (str, XCHAR (char_or_string));
1461 write_string_to_stdio_stream (file, con, str, 0, len, FORMAT_TERMINAL);
1464 return char_or_string;
1467 DEFUN ("open-termscript", Fopen_termscript, 1, 1, "FOpen termscript file: ", /*
1468 Start writing all terminal output to FILE as well as the terminal.
1469 FILE = nil means just close any termscript file currently open.
1473 /* This function can GC */
1474 if (termscript != 0)
1475 fclose (termscript);
1480 file = Fexpand_file_name (file, Qnil);
1481 termscript = fopen ((char *) XSTRING_DATA (file), "w");
1482 if (termscript == NULL)
1483 report_file_error ("Opening termscript", list1 (file));
1489 /* Debugging kludge -- unbuffered */
1490 static int debug_print_length = 50;
1491 static int debug_print_level = 15;
1494 debug_print_no_newline (Lisp_Object debug_print_obj)
1496 /* This function can GC */
1497 int old_print_readably = print_readably;
1498 int old_print_depth = print_depth;
1499 Lisp_Object old_print_length = Vprint_length;
1500 Lisp_Object old_print_level = Vprint_level;
1501 Lisp_Object old_inhibit_quit = Vinhibit_quit;
1502 struct gcpro gcpro1, gcpro2, gcpro3;
1503 GCPRO3 (old_print_level, old_print_length, old_inhibit_quit);
1506 stderr_out ("** gc-in-progress! Bad idea to print anything! **\n");
1511 /* Could use unwind-protect, but why bother? */
1512 if (debug_print_length > 0)
1513 Vprint_length = make_int (debug_print_length);
1514 if (debug_print_level > 0)
1515 Vprint_level = make_int (debug_print_level);
1516 print_internal (debug_print_obj, Qexternal_debugging_output, 1);
1517 Vinhibit_quit = old_inhibit_quit;
1518 Vprint_level = old_print_level;
1519 Vprint_length = old_print_length;
1520 print_depth = old_print_depth;
1521 print_readably = old_print_readably;
1527 debug_print (Lisp_Object debug_print_obj)
1529 debug_print_no_newline (debug_print_obj);
1534 /* Debugging kludge -- unbuffered */
1535 /* This function provided for the benefit of the debugger. */
1536 void debug_backtrace (void);
1538 debug_backtrace (void)
1540 /* This function can GC */
1541 int old_print_readably = print_readably;
1542 int old_print_depth = print_depth;
1543 Lisp_Object old_print_length = Vprint_length;
1544 Lisp_Object old_print_level = Vprint_level;
1545 Lisp_Object old_inhibit_quit = Vinhibit_quit;
1547 struct gcpro gcpro1, gcpro2, gcpro3;
1548 GCPRO3 (old_print_level, old_print_length, old_inhibit_quit);
1551 stderr_out ("** gc-in-progress! Bad idea to print anything! **\n");
1556 /* Could use unwind-protect, but why bother? */
1557 if (debug_print_length > 0)
1558 Vprint_length = make_int (debug_print_length);
1559 if (debug_print_level > 0)
1560 Vprint_level = make_int (debug_print_level);
1562 Fbacktrace (Qexternal_debugging_output, Qt);
1566 Vinhibit_quit = old_inhibit_quit;
1567 Vprint_level = old_print_level;
1568 Vprint_length = old_print_length;
1569 print_depth = old_print_depth;
1570 print_readably = old_print_readably;
1577 debug_short_backtrace (int length)
1580 struct backtrace *bt = backtrace_list;
1583 while (length > 0 && bt)
1590 if (COMPILED_FUNCTIONP (*bt->function))
1592 #if defined(COMPILED_FUNCTION_ANNOTATION_HACK)
1594 compiled_function_annotation (XCOMPILED_FUNCTION (*bt->function));
1596 Lisp_Object ann = Qnil;
1600 stderr_out ("<compiled-function from ");
1602 debug_print_no_newline (ann);
1608 stderr_out ("<compiled-function of unknown origin>");
1613 debug_print_no_newline (*bt->function);
1622 #endif /* debugging kludge */
1626 syms_of_print (void)
1628 defsymbol (&Qstandard_output, "standard-output");
1630 defsymbol (&Qprint_length, "print-length");
1632 defsymbol (&Qprint_string_length, "print-string-length");
1634 defsymbol (&Qdisplay_error, "display-error");
1635 defsymbol (&Qprint_message_label, "print-message-label");
1638 DEFSUBR (Fprin1_to_string);
1641 DEFSUBR (Ferror_message_string);
1642 DEFSUBR (Fdisplay_error);
1644 DEFSUBR (Fwrite_char);
1645 DEFSUBR (Falternate_debugging_output);
1646 DEFSUBR (Fexternal_debugging_output);
1647 DEFSUBR (Fopen_termscript);
1648 defsymbol (&Qexternal_debugging_output, "external-debugging-output");
1649 DEFSUBR (Fwith_output_to_temp_buffer);
1653 reinit_vars_of_print (void)
1655 alternate_do_pointer = 0;
1659 vars_of_print (void)
1661 reinit_vars_of_print ();
1663 DEFVAR_LISP ("standard-output", &Vstandard_output /*
1664 Output stream `print' uses by default for outputting a character.
1665 This may be any function of one argument.
1666 It may also be a buffer (output is inserted before point)
1667 or a marker (output is inserted and the marker is advanced)
1668 or the symbol t (output appears in the minibuffer line).
1670 Vstandard_output = Qt;
1672 #ifdef LISP_FLOAT_TYPE
1673 DEFVAR_LISP ("float-output-format", &Vfloat_output_format /*
1674 The format descriptor string that lisp uses to print floats.
1675 This is a %-spec like those accepted by `printf' in C,
1676 but with some restrictions. It must start with the two characters `%.'.
1677 After that comes an integer precision specification,
1678 and then a letter which controls the format.
1679 The letters allowed are `e', `f' and `g'.
1680 Use `e' for exponential notation "DIG.DIGITSeEXPT"
1681 Use `f' for decimal point notation "DIGITS.DIGITS".
1682 Use `g' to choose the shorter of those two formats for the number at hand.
1683 The precision in any of these cases is the number of digits following
1684 the decimal point. With `f', a precision of 0 means to omit the
1685 decimal point. 0 is not allowed with `f' or `g'.
1687 A value of nil means to use `%.16g'.
1689 Regardless of the value of `float-output-format', a floating point number
1690 will never be printed in such a way that it is ambiguous with an integer;
1691 that is, a floating-point number will always be printed with a decimal
1692 point and/or an exponent, even if the digits following the decimal point
1693 are all zero. This is to preserve read-equivalence.
1695 Vfloat_output_format = Qnil;
1696 #endif /* LISP_FLOAT_TYPE */
1698 DEFVAR_LISP ("print-length", &Vprint_length /*
1699 Maximum length of list or vector to print before abbreviating.
1700 A value of nil means no limit.
1702 Vprint_length = Qnil;
1704 DEFVAR_LISP ("print-string-length", &Vprint_string_length /*
1705 Maximum length of string to print before abbreviating.
1706 A value of nil means no limit.
1708 Vprint_string_length = Qnil;
1710 DEFVAR_LISP ("print-level", &Vprint_level /*
1711 Maximum depth of list nesting to print before abbreviating.
1712 A value of nil means no limit.
1714 Vprint_level = Qnil;
1716 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines /*
1717 Non-nil means print newlines in strings as backslash-n.
1719 print_escape_newlines = 0;
1721 DEFVAR_BOOL ("print-readably", &print_readably /*
1722 If non-nil, then all objects will be printed in a readable form.
1723 If an object has no readable representation, then an error is signalled.
1724 When print-readably is true, compiled-function objects will be written in
1725 #[...] form instead of in #<compiled-function [...]> form, and two-element
1726 lists of the form (quote object) will be written as the equivalent 'object.
1727 Do not SET this variable; bind it instead.
1731 /* #### I think this should default to t. But we'd better wait
1732 until we see that it works out. */
1733 DEFVAR_LISP ("print-gensym", &Vprint_gensym /*
1734 If non-nil, then uninterned symbols will be printed specially.
1735 Uninterned symbols are those which are not present in `obarray', that is,
1736 those which were made with `make-symbol' or by calling `intern' with a
1739 When print-gensym is true, such symbols will be preceded by "#:",
1740 which causes the reader to create a new symbol instead of interning
1741 and returning an existing one. Beware: the #: syntax creates a new
1742 symbol each time it is seen, so if you print an object which contains
1743 two pointers to the same uninterned symbol, `read' will not duplicate
1746 If the value of `print-gensym' is a cons cell, then in addition
1747 refrain from clearing `print-gensym-alist' on entry to and exit from
1748 printing functions, so that the use of #...# and #...= can carry over
1749 for several separately printed objects.
1751 Vprint_gensym = Qnil;
1753 DEFVAR_LISP ("print-gensym-alist", &Vprint_gensym_alist /*
1754 Association list of elements (GENSYM . N) to guide use of #N# and #N=.
1755 In each element, GENSYM is an uninterned symbol that has been associated
1756 with #N= for the specified value of N.
1758 Vprint_gensym_alist = Qnil;
1760 DEFVAR_LISP ("print-message-label", &Vprint_message_label /*
1761 Label for minibuffer messages created with `print'. This should
1762 generally be bound with `let' rather than set. (See `display-message'.)
1764 Vprint_message_label = Qprint;