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;
54 Lisp_Object Qalternate_debugging_output;
56 /* Avoid actual stack overflow in print. */
57 static int print_depth;
59 /* Detect most circularities to print finite output. */
60 #define PRINT_CIRCLE 200
61 Lisp_Object being_printed[PRINT_CIRCLE];
63 /* Maximum length of list or vector to print in full; noninteger means
64 effectively infinity */
66 Lisp_Object Vprint_length;
67 Lisp_Object Qprint_length;
69 /* Maximum length of string to print in full; noninteger means
70 effectively infinity */
72 Lisp_Object Vprint_string_length;
73 Lisp_Object Qprint_string_length;
75 /* Maximum depth of list to print in full; noninteger means
76 effectively infinity. */
78 Lisp_Object Vprint_level;
80 /* Label to use when making echo-area messages. */
82 Lisp_Object Vprint_message_label;
84 /* Nonzero means print newlines in strings as \n. */
86 int print_escape_newlines;
89 /* Non-nil means print #: before uninterned symbols.
90 Neither t nor nil means so that and don't clear Vprint_gensym_alist
91 on entry to and exit from print functions. */
92 Lisp_Object Vprint_gensym;
93 Lisp_Object Vprint_gensym_alist;
95 Lisp_Object Qprint_escape_newlines;
96 Lisp_Object Qprint_readably;
98 Lisp_Object Qdisplay_error;
99 Lisp_Object Qprint_message_label;
101 /* Force immediate output of all printed data. Used for debugging. */
102 int print_unbuffered;
104 FILE *termscript; /* Stdio stream being used for copy of all output. */
108 int stdout_needs_newline;
110 /* Write a string (in internal format) to stdio stream STREAM. */
113 write_string_to_stdio_stream (FILE *stream, struct console *con,
115 Bytecount offset, Bytecount len,
116 enum external_data_format fmt)
119 CONST Extbyte *extptr;
121 GET_CHARPTR_EXT_DATA_ALLOCA (str + offset, len, fmt, extptr, extlen);
124 fwrite (extptr, 1, extlen, stream);
126 /* Q122442 says that pipes are "treated as files, not as
127 devices", and that this is a feature. Before I found that
128 article, I thought it was a bug. Thanks MS, I feel much
130 if (stream == stdout || stream == stderr)
136 assert (CONSOLE_TTY_P (con));
137 Lstream_write (XLSTREAM (CONSOLE_TTY_DATA (con)->outstream),
140 if (stream == stdout || stream == stderr ||
141 (!stream && CONSOLE_TTY_DATA (con)->is_stdio))
145 fwrite (extptr, 1, extlen, termscript);
148 stdout_needs_newline = (extptr[extlen - 1] != '\n');
152 /* Write a string to the output location specified in FUNCTION.
153 Arguments NONRELOC, RELOC, OFFSET, and LEN are as in
154 buffer_insert_string_1() in insdel.c. */
157 output_string (Lisp_Object function, CONST Bufbyte *nonreloc,
158 Lisp_Object reloc, Bytecount offset, Bytecount len)
160 /* This function can GC */
162 /* We change the value of nonreloc (fetching it from reloc as
163 necessary), but we don't want to pass this changed value on to
164 other functions that take both a nonreloc and a reloc, or things
165 may get confused and an assertion failure in
166 fixup_internal_substring() may get triggered. */
167 CONST Bufbyte *newnonreloc = nonreloc;
168 struct gcpro gcpro1, gcpro2;
170 /* Emacs won't print while GCing, but an external debugger might */
171 if (gc_in_progress) return;
173 /* Perhaps not necessary but probably safer. */
174 GCPRO2 (function, reloc);
176 fixup_internal_substring (newnonreloc, reloc, offset, &len);
179 newnonreloc = XSTRING_DATA (reloc);
181 cclen = bytecount_to_charcount (newnonreloc + offset, len);
183 if (LSTREAMP (function))
187 /* Protect against Lstream_write() causing a GC and
188 relocating the string. For small strings, we do it by
189 alloc'ing the string and using a copy; for large strings,
193 Bufbyte *copied = alloca_array (Bufbyte, len);
194 memcpy (copied, newnonreloc + offset, len);
195 Lstream_write (XLSTREAM (function), copied, len);
199 int speccount = specpdl_depth ();
200 record_unwind_protect (restore_gc_inhibit,
201 make_int (gc_currently_forbidden));
202 gc_currently_forbidden = 1;
203 Lstream_write (XLSTREAM (function), newnonreloc + offset, len);
204 unbind_to (speccount, Qnil);
208 Lstream_write (XLSTREAM (function), newnonreloc + offset, len);
210 if (print_unbuffered)
211 Lstream_flush (XLSTREAM (function));
213 else if (BUFFERP (function))
215 CHECK_LIVE_BUFFER (function);
216 buffer_insert_string (XBUFFER (function), nonreloc, reloc, offset, len);
218 else if (MARKERP (function))
220 /* marker_position() will err if marker doesn't point anywhere. */
221 Bufpos spoint = marker_position (function);
223 buffer_insert_string_1 (XMARKER (function)->buffer,
224 spoint, nonreloc, reloc, offset, len,
226 Fset_marker (function, make_int (spoint + cclen),
227 Fmarker_buffer (function));
229 else if (FRAMEP (function))
231 /* This gets used by functions not invoking print_prepare(),
232 such as Fwrite_char, Fterpri, etc.. */
233 struct frame *f = XFRAME (function);
234 CHECK_LIVE_FRAME (function);
236 if (!EQ (Vprint_message_label, echo_area_status (f)))
237 clear_echo_area_from_print (f, Qnil, 1);
238 echo_area_append (f, nonreloc, reloc, offset, len, Vprint_message_label);
240 else if (EQ (function, Qt) || EQ (function, Qnil))
242 write_string_to_stdio_stream (stdout, 0, newnonreloc, offset, len,
247 Charcount ccoff = bytecount_to_charcount (newnonreloc, offset);
250 for (iii = ccoff; iii < cclen + ccoff; iii++)
253 make_char (charptr_emchar_n (newnonreloc, iii)));
255 newnonreloc = XSTRING_DATA (reloc);
262 #define RESET_PRINT_GENSYM do { \
263 if (!CONSP (Vprint_gensym)) \
264 Vprint_gensym_alist = Qnil; \
268 canonicalize_printcharfun (Lisp_Object printcharfun)
270 if (NILP (printcharfun))
271 printcharfun = Vstandard_output;
273 if (EQ (printcharfun, Qt) || NILP (printcharfun))
274 printcharfun = Fselected_frame (Qnil); /* print to minibuffer */
280 print_prepare (Lisp_Object printcharfun, Lisp_Object *frame_kludge)
282 /* Emacs won't print while GCing, but an external debugger might */
288 printcharfun = canonicalize_printcharfun (printcharfun);
290 /* Here we could safely return the canonicalized PRINTCHARFUN.
291 However, if PRINTCHARFUN is a frame, printing of complex
292 structures becomes very expensive, because `append-message'
293 (called by echo_area_append) gets called as many times as
294 output_string() is called (and that's a *lot*). append-message
295 tries to keep top of the message-stack in sync with the contents
296 of " *Echo Area" buffer, consing a new string for each component
297 of the printed structure. For instance, if you print (a a),
298 append-message will cons up the following strings:
306 and will use only the last one. With larger objects, this turns
307 into an O(n^2) consing frenzy that locks up XEmacs in incessant
310 We prevent this by creating a resizing_buffer stream and letting
311 the printer write into it. print_finish() will notice this
312 stream, and invoke echo_area_append() with the stream's buffer,
314 if (FRAMEP (printcharfun))
316 CHECK_LIVE_FRAME (printcharfun);
317 *frame_kludge = printcharfun;
318 printcharfun = make_resizing_buffer_output_stream ();
325 print_finish (Lisp_Object stream, Lisp_Object frame_kludge)
327 /* Emacs won't print while GCing, but an external debugger might */
333 /* See the comment in print_prepare(). */
334 if (FRAMEP (frame_kludge))
336 struct frame *f = XFRAME (frame_kludge);
337 Lstream *str = XLSTREAM (stream);
338 CHECK_LIVE_FRAME (frame_kludge);
341 if (!EQ (Vprint_message_label, echo_area_status (f)))
342 clear_echo_area_from_print (f, Qnil, 1);
343 echo_area_append (f, resizing_buffer_stream_ptr (str),
344 Qnil, 0, Lstream_byte_count (str),
345 Vprint_message_label);
346 Lstream_delete (str);
350 /* Used for printing a single-byte character (*not* any Emchar). */
351 #define write_char_internal(string_of_length_1, stream) \
352 output_string (stream, (CONST Bufbyte *) (string_of_length_1), \
355 /* NOTE: Do not call this with the data of a Lisp_String, as
356 printcharfun might cause a GC, which might cause the string's data
357 to be relocated. To princ a Lisp string, use:
359 print_internal (string, printcharfun, 0);
361 Also note that STREAM should be the result of
362 canonicalize_printcharfun() (i.e. Qnil means stdout, not
363 Vstandard_output, etc.) */
365 write_string_1 (CONST Bufbyte *str, Bytecount size, Lisp_Object stream)
367 /* This function can GC */
368 #ifdef ERROR_CHECK_BUFPOS
371 output_string (stream, str, Qnil, 0, size);
375 write_c_string (CONST char *str, Lisp_Object stream)
377 /* This function can GC */
378 write_string_1 ((CONST Bufbyte *) str, strlen (str), stream);
382 DEFUN ("write-char", Fwrite_char, 1, 2, 0, /*
383 Output character CH to stream STREAM.
384 STREAM defaults to the value of `standard-output' (which see).
388 /* This function can GC */
389 Bufbyte str[MAX_EMCHAR_LEN];
392 CHECK_CHAR_COERCE_INT (ch);
393 len = set_charptr_emchar (str, XCHAR (ch));
394 output_string (canonicalize_printcharfun (stream), str, Qnil, 0, len);
399 temp_output_buffer_setup (Lisp_Object bufname)
401 /* This function can GC */
402 struct buffer *old = current_buffer;
406 /* #### This function should accept a Lisp_Object instead of a char *,
407 so that proper translation on the buffer name can occur. */
410 Fset_buffer (Fget_buffer_create (bufname));
412 current_buffer->read_only = Qnil;
413 Ferase_buffer (Qnil);
415 XSETBUFFER (buf, current_buffer);
416 specbind (Qstandard_output, buf);
418 set_buffer_internal (old);
422 internal_with_output_to_temp_buffer (Lisp_Object bufname,
423 Lisp_Object (*function) (Lisp_Object arg),
425 Lisp_Object same_frame)
427 int speccount = specpdl_depth ();
428 struct gcpro gcpro1, gcpro2, gcpro3;
429 Lisp_Object buf = Qnil;
431 GCPRO3 (buf, arg, same_frame);
433 temp_output_buffer_setup (bufname);
434 buf = Vstandard_output;
436 arg = (*function) (arg);
438 temp_output_buffer_show (buf, same_frame);
441 return unbind_to (speccount, arg);
444 DEFUN ("with-output-to-temp-buffer", Fwith_output_to_temp_buffer, 1, UNEVALLED, 0, /*
445 Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
446 The buffer is cleared out initially, and marked as unmodified when done.
447 All output done by BODY is inserted in that buffer by default.
448 The buffer is displayed in another window, but not selected.
449 The value of the last form in BODY is returned.
450 If BODY does not finish normally, the buffer BUFNAME is not displayed.
452 If variable `temp-buffer-show-function' is non-nil, call it at the end
453 to get the buffer displayed. It gets one argument, the buffer to display.
457 /* This function can GC */
458 Lisp_Object name = Qnil;
459 int speccount = specpdl_depth ();
460 struct gcpro gcpro1, gcpro2;
461 Lisp_Object val = Qnil;
464 /* #### should set the buffer to be translating. See print_internal(). */
468 name = Feval (XCAR (args));
472 temp_output_buffer_setup (name);
475 val = Fprogn (XCDR (args));
477 temp_output_buffer_show (Vstandard_output, Qnil);
479 return unbind_to (speccount, val);
482 DEFUN ("terpri", Fterpri, 0, 1, 0, /*
483 Output a newline to STREAM.
484 If STREAM is omitted or nil, the value of `standard-output' is used.
488 /* This function can GC */
489 write_char_internal ("\n", canonicalize_printcharfun (stream));
493 DEFUN ("prin1", Fprin1, 1, 2, 0, /*
494 Output the printed representation of OBJECT, any Lisp object.
495 Quoting characters are printed when needed to make output that `read'
496 can handle, whenever this is possible.
497 Output stream is STREAM, or value of `standard-output' (which see).
501 /* This function can GC */
502 Lisp_Object frame = Qnil;
503 struct gcpro gcpro1, gcpro2;
504 GCPRO2 (object, stream);
507 stream = print_prepare (stream, &frame);
508 print_internal (object, stream, 1);
509 print_finish (stream, frame);
515 DEFUN ("prin1-to-string", Fprin1_to_string, 1, 2, 0, /*
516 Return a string containing the printed representation of OBJECT,
517 any Lisp object. Quoting characters are used when needed to make output
518 that `read' can handle, whenever this is possible, unless the optional
519 second argument NOESCAPE is non-nil.
523 /* This function can GC */
524 Lisp_Object result = Qnil;
525 Lisp_Object stream = make_resizing_buffer_output_stream ();
526 Lstream *str = XLSTREAM (stream);
527 /* gcpro OBJECT in case a caller forgot to do so */
528 struct gcpro gcpro1, gcpro2, gcpro3;
529 GCPRO3 (object, stream, result);
533 print_internal (object, stream, NILP (noescape));
537 result = make_string (resizing_buffer_stream_ptr (str),
538 Lstream_byte_count (str));
539 Lstream_delete (str);
543 DEFUN ("princ", Fprinc, 1, 2, 0, /*
544 Output the printed representation of OBJECT, any Lisp object.
545 No quoting characters are used; no delimiters are printed around
546 the contents of strings.
547 Output stream is STREAM, or value of standard-output (which see).
551 /* This function can GC */
552 Lisp_Object frame = Qnil;
553 struct gcpro gcpro1, gcpro2;
555 GCPRO2 (object, stream);
556 stream = print_prepare (stream, &frame);
558 print_internal (object, stream, 0);
559 print_finish (stream, frame);
564 DEFUN ("print", Fprint, 1, 2, 0, /*
565 Output the printed representation of OBJECT, with newlines around it.
566 Quoting characters are printed when needed to make output that `read'
567 can handle, whenever this is possible.
568 Output stream is STREAM, or value of `standard-output' (which see).
572 /* This function can GC */
573 Lisp_Object frame = Qnil;
574 struct gcpro gcpro1, gcpro2;
576 GCPRO2 (object, stream);
577 stream = print_prepare (stream, &frame);
579 write_char_internal ("\n", stream);
580 print_internal (object, stream, 1);
581 write_char_internal ("\n", stream);
582 print_finish (stream, frame);
587 /* Print an error message for the error DATA to STREAM. This is a
588 complete implementation of `display-error', which used to be in
589 Lisp (see prim/cmdloop.el). It was ported to C so it can be used
590 efficiently by Ferror_message_string. Fdisplay_error and
591 Ferror_message_string are trivial wrappers around this function.
593 STREAM should be the result of canonicalize_printcharfun(). */
595 print_error_message (Lisp_Object error_object, Lisp_Object stream)
597 /* This function can GC */
598 Lisp_Object type = Fcar_safe (error_object);
599 Lisp_Object method = Qnil;
602 /* No need to GCPRO anything under the assumption that ERROR_OBJECT
605 if (! (CONSP (error_object) && SYMBOLP (type)
606 && CONSP (Fget (type, Qerror_conditions, Qnil))))
609 tail = XCDR (error_object);
617 tail = Fget (type, Qerror_conditions, Qnil);
620 if (!(CONSP (tail) && SYMBOLP (XCAR (tail))))
622 else if (!NILP (Fget (XCAR (tail), Qdisplay_error, Qnil)))
624 method = Fget (XCAR (tail), Qdisplay_error, Qnil);
633 int speccount = specpdl_depth ();
635 specbind (Qprint_message_label, Qerror);
636 tail = Fcdr (error_object);
637 if (EQ (type, Qerror))
639 print_internal (Fcar (tail), stream, 0);
644 Lisp_Object errmsg = Fget (type, Qerror_message, Qnil);
646 print_internal (type, stream, 0);
648 print_internal (LISP_GETTEXT (errmsg), stream, 0);
652 write_c_string (first ? ": " : ", ", stream);
653 print_internal (Fcar (tail), stream, 1);
657 unbind_to (speccount, Qnil);
665 write_c_string (GETTEXT ("Peculiar error "), stream);
666 print_internal (error_object, stream, 1);
671 call2 (method, error_object, stream);
675 DEFUN ("error-message-string", Ferror_message_string, 1, 1, 0, /*
676 Convert ERROR-OBJECT to an error message, and return it.
678 The format of ERROR-OBJECT should be (ERROR-SYMBOL . DATA). The
679 message is equivalent to the one that would be issued by
680 `display-error' with the same argument.
684 /* This function can GC */
685 Lisp_Object result = Qnil;
686 Lisp_Object stream = make_resizing_buffer_output_stream ();
690 print_error_message (error_object, stream);
691 Lstream_flush (XLSTREAM (stream));
692 result = make_string (resizing_buffer_stream_ptr (XLSTREAM (stream)),
693 Lstream_byte_count (XLSTREAM (stream)));
694 Lstream_delete (XLSTREAM (stream));
700 DEFUN ("display-error", Fdisplay_error, 2, 2, 0, /*
701 Display ERROR-OBJECT on STREAM in a user-friendly way.
703 (error_object, stream))
705 /* This function can GC */
706 print_error_message (error_object, canonicalize_printcharfun (stream));
711 #ifdef LISP_FLOAT_TYPE
713 Lisp_Object Vfloat_output_format;
714 Lisp_Object Qfloat_output_format;
717 * This buffer should be at least as large as the max string size of the
718 * largest float, printed in the biggest notation. This is undoubtably
719 * 20d float_output_format, with the negative of the C-constant "HUGE"
722 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
724 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
725 * case of -1e307 in 20d float_output_format. What is one to do (short of
726 * re-writing _doprnt to be more sane)?
730 float_to_string (char *buf, double data)
735 if (NILP (Vfloat_output_format)
736 || !STRINGP (Vfloat_output_format))
738 sprintf (buf, "%.16g", data);
741 /* Check that the spec we have is fully valid.
742 This means not only valid for printf,
743 but meant for floats, and reasonable. */
744 cp = XSTRING_DATA (Vfloat_output_format);
752 for (width = 0; (c = *cp, isdigit (c)); cp++)
758 if (*cp != 'e' && *cp != 'f' && *cp != 'g' && *cp != 'E' && *cp != 'G')
761 if (width < (int) (*cp != 'e' && *cp != 'E') || width > DBL_DIG)
767 sprintf (buf, (char *) XSTRING_DATA (Vfloat_output_format),
771 /* added by jwz: don't allow "1.0" to print as "1"; that destroys
772 the read-equivalence of lisp objects. (* x 1) and (* x 1.0) do
773 not do the same thing, so it's important that the printed
774 representation of that form not be corrupted by the printer.
777 Bufbyte *s = (Bufbyte *) buf; /* don't use signed chars here!
778 isdigit() can't hack them! */
781 /* if there's a non-digit, then there is a decimal point, or
782 it's in exponential notation, both of which are ok. */
785 /* otherwise, we need to hack it. */
792 /* Some machines print "0.4" as ".4". I don't like that. */
793 if (buf [0] == '.' || (buf [0] == '-' && buf [1] == '.'))
796 for (i = strlen (buf) + 1; i >= 0; i--)
798 buf [(buf [0] == '-' ? 1 : 0)] = '0';
801 #endif /* LISP_FLOAT_TYPE */
803 /* Print NUMBER to BUFFER. The digits are first written in reverse
804 order (the least significant digit first), and are then reversed.
805 This is equivalent to sprintf(buffer, "%ld", number), only much
808 BUFFER should accept 24 bytes. This should suffice for the longest
809 numbers on 64-bit machines. */
811 long_to_string (char *buffer, long number)
823 /* Print the digits to the string. */
826 *p++ = number % 10 + '0';
831 /* And reverse them. */
832 len = p - buffer - 1;
833 for (i = len / 2; i >= 0; i--)
836 buffer[i] = buffer[len - i];
839 buffer[len + 1] = '\0';
843 print_vector_internal (CONST char *start, CONST char *end,
845 Lisp_Object printcharfun, int escapeflag)
847 /* This function can GC */
849 int len = XVECTOR_LENGTH (obj);
851 struct gcpro gcpro1, gcpro2;
852 GCPRO2 (obj, printcharfun);
854 if (INTP (Vprint_length))
856 int max = XINT (Vprint_length);
857 if (max < len) last = max;
860 write_c_string (start, printcharfun);
861 for (i = 0; i < last; i++)
863 Lisp_Object elt = XVECTOR_DATA (obj)[i];
864 if (i != 0) write_char_internal (" ", printcharfun);
865 print_internal (elt, printcharfun, escapeflag);
869 write_c_string (" ...", printcharfun);
870 write_c_string (end, printcharfun);
874 print_cons (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
876 /* This function can GC */
877 struct gcpro gcpro1, gcpro2;
879 /* If print_readably is on, print (quote -foo-) as '-foo-
880 (Yeah, this should really be what print-pretty does, but we
881 don't have the rest of a pretty printer, and this actually
882 has non-negligible impact on size/speed of .elc files.)
884 if (print_readably &&
885 EQ (XCAR (obj), Qquote) &&
886 CONSP (XCDR (obj)) &&
887 NILP (XCDR (XCDR (obj))))
889 obj = XCAR (XCDR (obj));
890 GCPRO2 (obj, printcharfun);
891 write_char_internal ("\'", printcharfun);
893 print_internal (obj, printcharfun, escapeflag);
897 GCPRO2 (obj, printcharfun);
898 write_char_internal ("(", printcharfun);
902 int max = INTP (Vprint_length) ? XINT (Vprint_length) : INT_MAX;
903 Lisp_Object tortoise;
904 /* Use tortoise/hare to make sure circular lists don't infloop */
906 for (tortoise = obj, len = 0;
908 obj = XCDR (obj), len++)
911 write_char_internal (" ", printcharfun);
912 if (EQ (obj, tortoise) && len > 0)
915 error ("printing unreadable circular list");
917 write_c_string ("... <circular list>", printcharfun);
921 tortoise = XCDR (tortoise);
924 write_c_string ("...", printcharfun);
927 print_internal (XCAR (obj), printcharfun, escapeflag);
932 write_c_string (" . ", printcharfun);
933 print_internal (obj, printcharfun, escapeflag);
937 write_char_internal (")", printcharfun);
942 print_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
944 print_vector_internal ("[", "]", obj, printcharfun, escapeflag);
948 print_string (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
950 struct Lisp_String *s = XSTRING (obj);
951 /* We distinguish between Bytecounts and Charcounts, to make
952 Vprint_string_length work correctly under Mule. */
953 Charcount size = string_char_length (s);
954 Charcount max = size;
955 Bytecount bcmax = string_length (s);
956 struct gcpro gcpro1, gcpro2;
957 GCPRO2 (obj, printcharfun);
959 if (INTP (Vprint_string_length) &&
960 XINT (Vprint_string_length) < max)
962 max = XINT (Vprint_string_length);
963 bcmax = charcount_to_bytecount (string_data (s), max);
973 /* This deals with GC-relocation and Mule. */
974 output_string (printcharfun, 0, obj, 0, bcmax);
976 write_c_string (" ...", printcharfun);
980 Bytecount i, last = 0;
982 write_char_internal ("\"", printcharfun);
983 for (i = 0; i < bcmax; i++)
985 Bufbyte ch = string_byte (s, i);
986 if (ch == '\"' || ch == '\\'
987 || (ch == '\n' && print_escape_newlines))
991 output_string (printcharfun, 0, obj, last,
996 write_c_string ("\\n", printcharfun);
1000 write_char_internal ("\\", printcharfun);
1001 /* This is correct for Mule because the
1002 character is either \ or " */
1003 write_char_internal (string_data (s) + i, printcharfun);
1010 output_string (printcharfun, 0, obj, last,
1014 write_c_string (" ...", printcharfun);
1015 write_char_internal ("\"", printcharfun);
1021 default_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
1024 struct lcrecord_header *header =
1025 (struct lcrecord_header *) XPNTR (obj);
1029 error ("printing unreadable object #<%s 0x%x>",
1030 LHEADER_IMPLEMENTATION (&header->lheader)->name,
1033 sprintf (buf, "#<%s 0x%x>",
1034 LHEADER_IMPLEMENTATION (&header->lheader)->name,
1036 write_c_string (buf, printcharfun);
1040 internal_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
1044 sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%lx>",
1045 XRECORD_LHEADER_IMPLEMENTATION (obj)->name,
1046 (unsigned long) XPNTR (obj));
1047 write_c_string (buf, printcharfun);
1051 print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1053 /* This function can GC */
1057 /* Emacs won't print while GCing, but an external debugger might */
1058 if (gc_in_progress) return;
1061 /* #### Both input and output streams should have a flag associated
1062 with them indicating whether output to that stream, or strings
1063 read from the stream, get translated using Fgettext(). Such a
1064 stream is called a "translating stream". For the minibuffer and
1065 external-debugging-output this is always true on output, and
1066 with-output-to-temp-buffer sets the flag to true for the buffer
1067 it creates. This flag should also be user-settable. Perhaps it
1068 should be split up into two flags, one for input and one for
1072 /* Detect circularities and truncate them.
1073 No need to offer any alternative--this is better than an error. */
1074 if (CONSP (obj) || VECTORP (obj) || COMPILED_FUNCTIONP (obj))
1077 for (i = 0; i < print_depth; i++)
1078 if (EQ (obj, being_printed[i]))
1082 long_to_string (buf + 1, i);
1083 write_c_string (buf, printcharfun);
1088 being_printed[print_depth] = obj;
1091 if (print_depth > PRINT_CIRCLE)
1092 error ("Apparently circular structure being printed");
1094 switch (XTYPE (obj))
1096 #ifdef USE_MINIMAL_TAGBITS
1097 case Lisp_Type_Int_Even:
1098 case Lisp_Type_Int_Odd:
1104 long_to_string (buf, XINT (obj));
1105 write_c_string (buf, printcharfun);
1109 case Lisp_Type_Char:
1111 /* God intended that this be #\..., you know. */
1113 Emchar ch = XCHAR (obj);
1117 *p++ = '\\', *p++ = 'n';
1118 else if (ch == '\r')
1119 *p++ = '\\', *p++ = 'r';
1120 else if (ch == '\t')
1121 *p++ = '\\', *p++ = 't';
1124 *p++ = '\\', *p++ = '^';
1126 if ((ch + 64) == '\\')
1130 *p++ = '\\', *p++ = '^', *p++ = '?';
1131 else if (ch >= 128 && ch < 160)
1133 *p++ = '\\', *p++ = '^';
1134 p += set_charptr_emchar ((Bufbyte *)p, ch + 64);
1139 && ch != '^') /* must not backslash this or it will
1140 be interpreted as the start of a
1142 *p++ = '\\', *p++ = ch;
1144 p += set_charptr_emchar ((Bufbyte *)p, ch);
1145 output_string (printcharfun, (Bufbyte *)buf, Qnil, 0, p - buf);
1149 #ifndef LRECORD_STRING
1150 case Lisp_Type_String:
1152 print_string (obj, printcharfun, escapeflag);
1155 #endif /* ! LRECORD_STRING */
1157 #ifndef LRECORD_CONS
1158 case Lisp_Type_Cons:
1160 struct gcpro gcpro1, gcpro2;
1162 /* If deeper than spec'd depth, print placeholder. */
1163 if (INTP (Vprint_level)
1164 && print_depth > XINT (Vprint_level))
1166 GCPRO2 (obj, printcharfun);
1167 write_c_string ("...", printcharfun);
1172 print_cons (obj, printcharfun, escapeflag);
1175 #endif /* ! LRECORD_CONS */
1177 #ifndef LRECORD_VECTOR
1178 case Lisp_Type_Vector:
1180 /* If deeper than spec'd depth, print placeholder. */
1181 if (INTP (Vprint_level)
1182 && print_depth > XINT (Vprint_level))
1184 struct gcpro gcpro1, gcpro2;
1185 GCPRO2 (obj, printcharfun);
1186 write_c_string ("...", printcharfun);
1191 /* God intended that this be #(...), you know. */
1192 print_vector_internal ("[", "]", obj, printcharfun, escapeflag);
1195 #endif /* !LRECORD_VECTOR */
1197 #ifndef LRECORD_SYMBOL
1198 case Lisp_Type_Symbol:
1200 print_symbol (obj, printcharfun, escapeflag);
1203 #endif /* !LRECORD_SYMBOL */
1205 case Lisp_Type_Record:
1207 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
1208 struct gcpro gcpro1, gcpro2;
1210 #if defined(LRECORD_CONS) || defined(LRECORD_VECTOR)
1211 if (CONSP (obj) || VECTORP(obj))
1213 /* If deeper than spec'd depth, print placeholder. */
1214 if (INTP (Vprint_level)
1215 && print_depth > XINT (Vprint_level))
1217 GCPRO2 (obj, printcharfun);
1218 write_c_string ("...", printcharfun);
1225 GCPRO2 (obj, printcharfun);
1226 if (LHEADER_IMPLEMENTATION (lheader)->printer)
1227 ((LHEADER_IMPLEMENTATION (lheader)->printer)
1228 (obj, printcharfun, escapeflag));
1230 default_object_printer (obj, printcharfun, escapeflag);
1237 #ifdef ERROR_CHECK_TYPECHECK
1239 #else /* not ERROR_CHECK_TYPECHECK */
1241 /* We're in trouble if this happens! */
1243 error ("printing illegal data type #o%03o",
1245 write_c_string ("#<EMACS BUG: ILLEGAL DATATYPE ",
1247 sprintf (buf, "(#o%3o)", (int) XTYPE (obj));
1248 write_c_string (buf, printcharfun);
1250 (" Save your buffers immediately and please report this bug>",
1252 #endif /* not ERROR_CHECK_TYPECHECK */
1261 #ifdef LISP_FLOAT_TYPE
1263 print_float (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1265 char pigbuf[350]; /* see comments in float_to_string */
1267 float_to_string (pigbuf, XFLOAT_DATA (obj));
1268 write_c_string (pigbuf, printcharfun);
1270 #endif /* LISP_FLOAT_TYPE */
1273 print_symbol (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1275 /* This function can GC */
1276 /* #### Bug!! (intern "") isn't printed in some distinguished way */
1277 /* #### (the reader also loses on it) */
1278 struct Lisp_String *name = symbol_name (XSYMBOL (obj));
1279 Bytecount size = string_length (name);
1280 struct gcpro gcpro1, gcpro2;
1284 /* This deals with GC-relocation */
1285 Lisp_Object nameobj;
1286 XSETSTRING (nameobj, name);
1287 output_string (printcharfun, 0, nameobj, 0, size);
1290 GCPRO2 (obj, printcharfun);
1292 /* If we print an uninterned symbol as part of a complex object and
1293 the flag print-gensym is non-nil, prefix it with #n= to read the
1294 object back with the #n# reader syntax later if needed. */
1295 if (!NILP (Vprint_gensym) && NILP (XSYMBOL (obj)->obarray))
1297 if (print_depth > 1)
1299 Lisp_Object tem = Fassq (obj, Vprint_gensym_alist);
1302 write_char_internal ("#", printcharfun);
1303 print_internal (XCDR (tem), printcharfun, escapeflag);
1304 write_char_internal ("#", printcharfun);
1309 if (CONSP (Vprint_gensym_alist))
1311 /* Vprint_gensym_alist is exposed to Lisp, so we
1312 have to be careful. */
1313 CHECK_CONS (XCAR (Vprint_gensym_alist));
1314 CHECK_INT (XCDR (XCAR (Vprint_gensym_alist)));
1315 XSETINT (tem, XINT (XCDR (XCAR (Vprint_gensym_alist))) + 1);
1319 Vprint_gensym_alist = Fcons (Fcons (obj, tem), Vprint_gensym_alist);
1321 write_char_internal ("#", printcharfun);
1322 print_internal (tem, printcharfun, escapeflag);
1323 write_char_internal ("=", printcharfun);
1326 write_c_string ("#:", printcharfun);
1329 /* Does it look like an integer or a float? */
1331 Bufbyte *data = string_data (name);
1332 Bytecount confusing = 0;
1335 goto not_yet_confused; /* Really confusing */
1336 else if (isdigit (data[0]))
1339 goto not_yet_confused;
1340 else if (data[0] == '-' || data[0] == '+')
1343 goto not_yet_confused;
1345 for (; confusing < size; confusing++)
1347 if (!isdigit (data[confusing]))
1355 #ifdef LISP_FLOAT_TYPE
1357 /* #### Ugh, this is needlessly complex and slow for what we
1358 need here. It might be a good idea to copy equivalent code
1359 from FSF. --hniksic */
1360 confusing = isfloat_string ((char *) data);
1363 write_char_internal ("\\", printcharfun);
1367 Lisp_Object nameobj;
1371 XSETSTRING (nameobj, name);
1372 for (i = 0; i < size; i++)
1374 switch (string_byte (name, i))
1376 case 0: case 1: case 2: case 3:
1377 case 4: case 5: case 6: case 7:
1378 case 8: case 9: case 10: case 11:
1379 case 12: case 13: case 14: case 15:
1380 case 16: case 17: case 18: case 19:
1381 case 20: case 21: case 22: case 23:
1382 case 24: case 25: case 26: case 27:
1383 case 28: case 29: case 30: case 31:
1384 case ' ': case '\"': case '\\': case '\'':
1385 case ';': case '#' : case '(' : case ')':
1386 case ',': case '.' : case '`' :
1387 case '[': case ']' : case '?' :
1389 output_string (printcharfun, 0, nameobj, last, i - last);
1390 write_char_internal ("\\", printcharfun);
1394 output_string (printcharfun, 0, nameobj, last, size - last);
1399 /* #ifdef DEBUG_XEMACS */
1401 /* I don't like seeing `Note: Strange doc (not fboundp) for function
1402 alternate-debugging-output @ 429542' -slb */
1403 /* #### Eek! Any clue how to get rid of it? In fact, how about
1404 getting rid of this function altogether? Does anything actually
1405 *use* it? --hniksic */
1407 int alternate_do_pointer;
1408 char alternate_do_string[5000];
1410 DEFUN ("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0, /*
1411 Append CHARACTER to the array `alternate_do_string'.
1412 This can be used in place of `external-debugging-output' as a function
1413 to be passed to `print'. Before calling `print', set `alternate_do_pointer'
1418 Bufbyte str[MAX_EMCHAR_LEN];
1421 CONST Extbyte *extptr;
1423 CHECK_CHAR_COERCE_INT (character);
1424 len = set_charptr_emchar (str, XCHAR (character));
1425 GET_CHARPTR_EXT_DATA_ALLOCA (str, len, FORMAT_TERMINAL, extptr, extlen);
1426 memcpy (alternate_do_string + alternate_do_pointer, extptr, extlen);
1427 alternate_do_pointer += extlen;
1428 alternate_do_string[alternate_do_pointer] = 0;
1431 /* #endif / * DEBUG_XEMACS */
1433 DEFUN ("external-debugging-output", Fexternal_debugging_output, 1, 3, 0, /*
1434 Write CHAR-OR-STRING to stderr or stdout.
1435 If optional arg STDOUT-P is non-nil, write to stdout; otherwise, write
1436 to stderr. You can use this function to write directly to the terminal.
1437 This function can be used as the STREAM argument of Fprint() or the like.
1439 If you have opened a termscript file (using `open-termscript'), then
1440 the output also will be logged to this file.
1442 (char_or_string, stdout_p, device))
1445 struct console *con = 0;
1449 if (!NILP (stdout_p))
1456 CHECK_LIVE_DEVICE (device);
1457 if (!DEVICE_TTY_P (XDEVICE (device)) &&
1458 !DEVICE_STREAM_P (XDEVICE (device)))
1459 signal_simple_error ("Must be tty or stream device", device);
1460 con = XCONSOLE (DEVICE_CONSOLE (XDEVICE (device)));
1461 if (DEVICE_TTY_P (XDEVICE (device)))
1463 else if (!NILP (stdout_p))
1464 file = CONSOLE_STREAM_DATA (con)->outfd;
1466 file = CONSOLE_STREAM_DATA (con)->errfd;
1469 if (STRINGP (char_or_string))
1470 write_string_to_stdio_stream (file, con,
1471 XSTRING_DATA (char_or_string),
1472 0, XSTRING_LENGTH (char_or_string),
1476 Bufbyte str[MAX_EMCHAR_LEN];
1479 CHECK_CHAR_COERCE_INT (char_or_string);
1480 len = set_charptr_emchar (str, XCHAR (char_or_string));
1481 write_string_to_stdio_stream (file, con, str, 0, len, FORMAT_TERMINAL);
1484 return char_or_string;
1487 DEFUN ("open-termscript", Fopen_termscript, 1, 1, "FOpen termscript file: ", /*
1488 Start writing all terminal output to FILE as well as the terminal.
1489 FILE = nil means just close any termscript file currently open.
1493 /* This function can GC */
1494 if (termscript != 0)
1495 fclose (termscript);
1500 file = Fexpand_file_name (file, Qnil);
1501 termscript = fopen ((char *) XSTRING_DATA (file), "w");
1502 if (termscript == NULL)
1503 report_file_error ("Opening termscript", list1 (file));
1509 /* Debugging kludge -- unbuffered */
1510 static int debug_print_length = 50;
1511 static int debug_print_level = 15;
1512 Lisp_Object debug_temp;
1515 debug_print_no_newline (Lisp_Object debug_print_obj)
1517 /* This function can GC */
1518 int old_print_readably = print_readably;
1519 int old_print_depth = print_depth;
1520 Lisp_Object old_print_length = Vprint_length;
1521 Lisp_Object old_print_level = Vprint_level;
1522 Lisp_Object old_inhibit_quit = Vinhibit_quit;
1523 struct gcpro gcpro1, gcpro2, gcpro3;
1524 GCPRO3 (old_print_level, old_print_length, old_inhibit_quit);
1527 stderr_out ("** gc-in-progress! Bad idea to print anything! **\n");
1532 /* Could use unwind-protect, but why bother? */
1533 if (debug_print_length > 0)
1534 Vprint_length = make_int (debug_print_length);
1535 if (debug_print_level > 0)
1536 Vprint_level = make_int (debug_print_level);
1537 print_internal (debug_print_obj, Qexternal_debugging_output, 1);
1538 Vinhibit_quit = old_inhibit_quit;
1539 Vprint_level = old_print_level;
1540 Vprint_length = old_print_length;
1541 print_depth = old_print_depth;
1542 print_readably = old_print_readably;
1548 debug_print (Lisp_Object debug_print_obj)
1550 debug_print_no_newline (debug_print_obj);
1555 /* Debugging kludge -- unbuffered */
1556 /* This function provided for the benefit of the debugger. */
1557 void debug_backtrace (void);
1559 debug_backtrace (void)
1561 /* This function can GC */
1562 int old_print_readably = print_readably;
1563 int old_print_depth = print_depth;
1564 Lisp_Object old_print_length = Vprint_length;
1565 Lisp_Object old_print_level = Vprint_level;
1566 Lisp_Object old_inhibit_quit = Vinhibit_quit;
1568 struct gcpro gcpro1, gcpro2, gcpro3;
1569 GCPRO3 (old_print_level, old_print_length, old_inhibit_quit);
1572 stderr_out ("** gc-in-progress! Bad idea to print anything! **\n");
1577 /* Could use unwind-protect, but why bother? */
1578 if (debug_print_length > 0)
1579 Vprint_length = make_int (debug_print_length);
1580 if (debug_print_level > 0)
1581 Vprint_level = make_int (debug_print_level);
1583 Fbacktrace (Qexternal_debugging_output, Qt);
1587 Vinhibit_quit = old_inhibit_quit;
1588 Vprint_level = old_print_level;
1589 Vprint_length = old_print_length;
1590 print_depth = old_print_depth;
1591 print_readably = old_print_readably;
1598 debug_short_backtrace (int length)
1601 struct backtrace *bt = backtrace_list;
1604 while (length > 0 && bt)
1611 if (COMPILED_FUNCTIONP (*bt->function))
1613 #if defined(COMPILED_FUNCTION_ANNOTATION_HACK)
1615 compiled_function_annotation (XCOMPILED_FUNCTION (*bt->function));
1617 Lisp_Object ann = Qnil;
1621 stderr_out ("<compiled-function from ");
1623 debug_print_no_newline (ann);
1629 stderr_out ("<compiled-function of unknown origin>");
1634 debug_print_no_newline (*bt->function);
1643 #endif /* debugging kludge */
1647 syms_of_print (void)
1649 defsymbol (&Qprint_escape_newlines, "print-escape-newlines");
1650 defsymbol (&Qprint_readably, "print-readably");
1652 defsymbol (&Qstandard_output, "standard-output");
1654 #ifdef LISP_FLOAT_TYPE
1655 defsymbol (&Qfloat_output_format, "float-output-format");
1658 defsymbol (&Qprint_length, "print-length");
1660 defsymbol (&Qprint_string_length, "print-string-length");
1662 defsymbol (&Qdisplay_error, "display-error");
1663 defsymbol (&Qprint_message_label, "print-message-label");
1666 DEFSUBR (Fprin1_to_string);
1669 DEFSUBR (Ferror_message_string);
1670 DEFSUBR (Fdisplay_error);
1672 DEFSUBR (Fwrite_char);
1673 DEFSUBR (Falternate_debugging_output);
1674 defsymbol (&Qalternate_debugging_output, "alternate-debugging-output");
1675 DEFSUBR (Fexternal_debugging_output);
1676 DEFSUBR (Fopen_termscript);
1677 defsymbol (&Qexternal_debugging_output, "external-debugging-output");
1678 DEFSUBR (Fwith_output_to_temp_buffer);
1682 vars_of_print (void)
1684 alternate_do_pointer = 0;
1686 DEFVAR_LISP ("standard-output", &Vstandard_output /*
1687 Output stream `print' uses by default for outputting a character.
1688 This may be any function of one argument.
1689 It may also be a buffer (output is inserted before point)
1690 or a marker (output is inserted and the marker is advanced)
1691 or the symbol t (output appears in the minibuffer line).
1693 Vstandard_output = Qt;
1695 #ifdef LISP_FLOAT_TYPE
1696 DEFVAR_LISP ("float-output-format", &Vfloat_output_format /*
1697 The format descriptor string that lisp uses to print floats.
1698 This is a %-spec like those accepted by `printf' in C,
1699 but with some restrictions. It must start with the two characters `%.'.
1700 After that comes an integer precision specification,
1701 and then a letter which controls the format.
1702 The letters allowed are `e', `f' and `g'.
1703 Use `e' for exponential notation "DIG.DIGITSeEXPT"
1704 Use `f' for decimal point notation "DIGITS.DIGITS".
1705 Use `g' to choose the shorter of those two formats for the number at hand.
1706 The precision in any of these cases is the number of digits following
1707 the decimal point. With `f', a precision of 0 means to omit the
1708 decimal point. 0 is not allowed with `f' or `g'.
1710 A value of nil means to use `%.16g'.
1712 Regardless of the value of `float-output-format', a floating point number
1713 will never be printed in such a way that it is ambiguous with an integer;
1714 that is, a floating-point number will always be printed with a decimal
1715 point and/or an exponent, even if the digits following the decimal point
1716 are all zero. This is to preserve read-equivalence.
1718 Vfloat_output_format = Qnil;
1719 #endif /* LISP_FLOAT_TYPE */
1721 DEFVAR_LISP ("print-length", &Vprint_length /*
1722 Maximum length of list or vector to print before abbreviating.
1723 A value of nil means no limit.
1725 Vprint_length = Qnil;
1727 DEFVAR_LISP ("print-string-length", &Vprint_string_length /*
1728 Maximum length of string to print before abbreviating.
1729 A value of nil means no limit.
1731 Vprint_string_length = Qnil;
1733 DEFVAR_LISP ("print-level", &Vprint_level /*
1734 Maximum depth of list nesting to print before abbreviating.
1735 A value of nil means no limit.
1737 Vprint_level = Qnil;
1739 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines /*
1740 Non-nil means print newlines in strings as backslash-n.
1742 print_escape_newlines = 0;
1744 DEFVAR_BOOL ("print-readably", &print_readably /*
1745 If non-nil, then all objects will be printed in a readable form.
1746 If an object has no readable representation, then an error is signalled.
1747 When print-readably is true, compiled-function objects will be written in
1748 #[...] form instead of in #<compiled-function [...]> form, and two-element
1749 lists of the form (quote object) will be written as the equivalent 'object.
1750 Do not SET this variable; bind it instead.
1754 /* #### I think this should default to t. But we'd better wait
1755 until we see that it works out. */
1756 DEFVAR_LISP ("print-gensym", &Vprint_gensym /*
1757 If non-nil, then uninterned symbols will be printed specially.
1758 Uninterned symbols are those which are not present in `obarray', that is,
1759 those which were made with `make-symbol' or by calling `intern' with a
1762 When print-gensym is true, such symbols will be preceded by "#:",
1763 which causes the reader to create a new symbol instead of interning
1764 and returning an existing one. Beware: the #: syntax creates a new
1765 symbol each time it is seen, so if you print an object which contains
1766 two pointers to the same uninterned symbol, `read' will not duplicate
1769 If the value of `print-gensym' is a cons cell, then in addition
1770 refrain from clearing `print-gensym-alist' on entry to and exit from
1771 printing functions, so that the use of #...# and #...= can carry over
1772 for several separately printed objects.
1774 Vprint_gensym = Qnil;
1776 DEFVAR_LISP ("print-gensym-alist", &Vprint_gensym_alist /*
1777 Association list of elements (GENSYM . N) to guide use of #N# and #N=.
1778 In each element, GENSYM is an uninterned symbol that has been associated
1779 with #N= for the specified value of N.
1781 Vprint_gensym_alist = Qnil;
1783 DEFVAR_LISP ("print-message-label", &Vprint_message_label /*
1784 Label for minibuffer messages created with `print'. This should
1785 generally be bound with `let' rather than set. (See `display-message'.)
1787 Vprint_message_label = Qprint;