1 /* Lisp object printing and output streams.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2015 Free Software
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
26 #include "character.h"
33 #include "dispextern.h"
36 #include "intervals.h"
37 #include "blockinput.h"
38 #include "termhooks.h" /* For struct terminal. */
45 /* Avoid actual stack overflow in print. */
46 static ptrdiff_t print_depth
;
48 /* Level of nesting inside outputting backquote in new style. */
49 static ptrdiff_t new_backquote_output
;
51 /* Detect most circularities to print finite output. */
52 #define PRINT_CIRCLE 200
53 static Lisp_Object being_printed
[PRINT_CIRCLE
];
55 /* Last char printed to stdout by printchar. */
56 static unsigned int printchar_stdout_last
;
58 /* When printing into a buffer, first we put the text in this
59 block, then insert it all at once. */
60 static char *print_buffer
;
62 /* Size allocated in print_buffer. */
63 static ptrdiff_t print_buffer_size
;
64 /* Chars stored in print_buffer. */
65 static ptrdiff_t print_buffer_pos
;
66 /* Bytes stored in print_buffer. */
67 static ptrdiff_t print_buffer_pos_byte
;
69 /* Vprint_number_table is a table, that keeps objects that are going to
70 be printed, to allow use of #n= and #n# to express sharing.
71 For any given object, the table can give the following values:
72 t the object will be printed only once.
73 -N the object will be printed several times and will take number N.
74 N the object has been printed so we can refer to it as #N#.
75 print_number_index holds the largest N already used.
76 N has to be striclty larger than 0 since we need to distinguish -N. */
77 static ptrdiff_t print_number_index
;
78 static void print_interval (INTERVAL interval
, Lisp_Object printcharfun
);
80 /* GDB resets this to zero on W32 to disable OutputDebugString calls. */
81 bool print_output_debug_flag EXTERNALLY_VISIBLE
= 1;
84 /* Low level output routines for characters and strings. */
86 /* Lisp functions to do output using a stream
87 must have the stream in a variable called printcharfun
88 and must start with PRINTPREPARE, end with PRINTFINISH.
89 Use printchar to output one character,
90 or call strout to output a block of characters. */
92 #define PRINTPREPARE \
93 struct buffer *old = current_buffer; \
94 ptrdiff_t old_point = -1, start_point = -1; \
95 ptrdiff_t old_point_byte = -1, start_point_byte = -1; \
96 ptrdiff_t specpdl_count = SPECPDL_INDEX (); \
97 bool free_print_buffer = 0; \
99 = !NILP (BVAR (current_buffer, enable_multibyte_characters)); \
100 Lisp_Object original = printcharfun; \
101 if (NILP (printcharfun)) printcharfun = Qt; \
102 if (BUFFERP (printcharfun)) \
104 if (XBUFFER (printcharfun) != current_buffer) \
105 Fset_buffer (printcharfun); \
106 printcharfun = Qnil; \
108 if (MARKERP (printcharfun)) \
110 ptrdiff_t marker_pos; \
111 if (! XMARKER (printcharfun)->buffer) \
112 error ("Marker does not point anywhere"); \
113 if (XMARKER (printcharfun)->buffer != current_buffer) \
114 set_buffer_internal (XMARKER (printcharfun)->buffer); \
115 marker_pos = marker_position (printcharfun); \
116 if (marker_pos < BEGV || marker_pos > ZV) \
117 signal_error ("Marker is outside the accessible " \
118 "part of the buffer", printcharfun); \
120 old_point_byte = PT_BYTE; \
121 SET_PT_BOTH (marker_pos, \
122 marker_byte_position (printcharfun)); \
124 start_point_byte = PT_BYTE; \
125 printcharfun = Qnil; \
127 if (NILP (printcharfun)) \
129 Lisp_Object string; \
130 if (NILP (BVAR (current_buffer, enable_multibyte_characters)) \
131 && ! print_escape_multibyte) \
132 specbind (Qprint_escape_multibyte, Qt); \
133 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)) \
134 && ! print_escape_nonascii) \
135 specbind (Qprint_escape_nonascii, Qt); \
136 if (print_buffer != 0) \
138 string = make_string_from_bytes (print_buffer, \
140 print_buffer_pos_byte); \
141 record_unwind_protect (print_unwind, string); \
145 int new_size = 1000; \
146 print_buffer = xmalloc (new_size); \
147 print_buffer_size = new_size; \
148 free_print_buffer = 1; \
150 print_buffer_pos = 0; \
151 print_buffer_pos_byte = 0; \
153 if (EQ (printcharfun, Qt) && ! noninteractive) \
154 setup_echo_area_for_printing (multibyte);
156 #define PRINTFINISH \
157 if (NILP (printcharfun)) \
159 if (print_buffer_pos != print_buffer_pos_byte \
160 && NILP (BVAR (current_buffer, enable_multibyte_characters)))\
163 unsigned char *temp = SAFE_ALLOCA (print_buffer_pos + 1); \
164 copy_text ((unsigned char *) print_buffer, temp, \
165 print_buffer_pos_byte, 1, 0); \
166 insert_1_both ((char *) temp, print_buffer_pos, \
167 print_buffer_pos, 0, 1, 0); \
171 insert_1_both (print_buffer, print_buffer_pos, \
172 print_buffer_pos_byte, 0, 1, 0); \
173 signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
175 if (free_print_buffer) \
177 xfree (print_buffer); \
180 unbind_to (specpdl_count, Qnil); \
181 if (MARKERP (original)) \
182 set_marker_both (original, Qnil, PT, PT_BYTE); \
183 if (old_point >= 0) \
184 SET_PT_BOTH (old_point + (old_point >= start_point \
185 ? PT - start_point : 0), \
186 old_point_byte + (old_point_byte >= start_point_byte \
187 ? PT_BYTE - start_point_byte : 0)); \
188 set_buffer_internal (old);
190 /* This is used to restore the saved contents of print_buffer
191 when there is a recursive call to print. */
194 print_unwind (Lisp_Object saved_text
)
196 memcpy (print_buffer
, SDATA (saved_text
), SCHARS (saved_text
));
199 /* Print character CH to the stdio stream STREAM. */
202 printchar_to_stream (unsigned int ch
, FILE *stream
)
204 Lisp_Object dv
IF_LINT (= Qnil
);
205 ptrdiff_t i
= 0, n
= 1;
207 if (CHAR_VALID_P (ch
) && DISP_TABLE_P (Vstandard_display_table
))
209 dv
= DISP_CHAR_VECTOR (XCHAR_TABLE (Vstandard_display_table
), ch
);
219 if (ASCII_CHAR_P (ch
))
223 /* Send the output to a debugger (nothing happens if there
225 if (print_output_debug_flag
&& stream
== stderr
)
226 OutputDebugString ((char []) {ch
, '\0'});
231 unsigned char mbstr
[MAX_MULTIBYTE_LENGTH
];
232 int len
= CHAR_STRING (ch
, mbstr
);
233 Lisp_Object encoded_ch
=
234 ENCODE_SYSTEM (make_multibyte_string ((char *) mbstr
, 1, len
));
236 fwrite (SSDATA (encoded_ch
), 1, SBYTES (encoded_ch
), stream
);
238 if (print_output_debug_flag
&& stream
== stderr
)
239 OutputDebugString (SSDATA (encoded_ch
));
247 if (CHARACTERP (AREF (dv
, i
)))
251 ch
= XFASTINT (AREF (dv
, i
));
255 /* Print character CH using method FUN. FUN nil means print to
256 print_buffer. FUN t means print to echo area or stdout if
257 non-interactive. If FUN is neither nil nor t, call FUN with CH as
261 printchar (unsigned int ch
, Lisp_Object fun
)
263 if (!NILP (fun
) && !EQ (fun
, Qt
))
264 call1 (fun
, make_number (ch
));
267 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
268 int len
= CHAR_STRING (ch
, str
);
274 ptrdiff_t incr
= len
- (print_buffer_size
- print_buffer_pos_byte
);
276 print_buffer
= xpalloc (print_buffer
, &print_buffer_size
,
278 memcpy (print_buffer
+ print_buffer_pos_byte
, str
, len
);
279 print_buffer_pos
+= 1;
280 print_buffer_pos_byte
+= len
;
282 else if (noninteractive
)
284 printchar_stdout_last
= ch
;
285 if (DISP_TABLE_P (Vstandard_display_table
))
286 printchar_to_stream (ch
, stdout
);
288 fwrite (str
, 1, len
, stdout
);
289 noninteractive_need_newline
= 1;
294 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
296 setup_echo_area_for_printing (multibyte_p
);
298 message_dolog ((char *) str
, len
, 0, multibyte_p
);
304 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
305 method PRINTCHARFUN. PRINTCHARFUN nil means output to
306 print_buffer. PRINTCHARFUN t means output to the echo area or to
307 stdout if non-interactive. If neither nil nor t, call Lisp
308 function PRINTCHARFUN for each character printed. MULTIBYTE
309 non-zero means PTR contains multibyte characters.
311 In the case where PRINTCHARFUN is nil, it is safe for PTR to point
312 to data in a Lisp string. Otherwise that is not safe. */
315 strout (const char *ptr
, ptrdiff_t size
, ptrdiff_t size_byte
,
316 Lisp_Object printcharfun
)
318 if (NILP (printcharfun
))
320 ptrdiff_t incr
= size_byte
- (print_buffer_size
- print_buffer_pos_byte
);
322 print_buffer
= xpalloc (print_buffer
, &print_buffer_size
, incr
, -1, 1);
323 memcpy (print_buffer
+ print_buffer_pos_byte
, ptr
, size_byte
);
324 print_buffer_pos
+= size
;
325 print_buffer_pos_byte
+= size_byte
;
327 else if (noninteractive
&& EQ (printcharfun
, Qt
))
329 if (DISP_TABLE_P (Vstandard_display_table
))
332 for (ptrdiff_t i
= 0; i
< size_byte
; i
+= len
)
334 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
336 printchar_to_stream (ch
, stdout
);
340 fwrite (ptr
, 1, size_byte
, stdout
);
342 noninteractive_need_newline
= 1;
344 else if (EQ (printcharfun
, Qt
))
346 /* Output to echo area. We're trying to avoid a little overhead
347 here, that's the reason we don't call printchar to do the
351 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
353 setup_echo_area_for_printing (multibyte_p
);
354 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
356 if (size
== size_byte
)
358 for (i
= 0; i
< size
; ++i
)
359 insert_char ((unsigned char) *ptr
++);
364 for (i
= 0; i
< size_byte
; i
+= len
)
366 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
374 /* PRINTCHARFUN is a Lisp function. */
377 if (size
== size_byte
)
379 while (i
< size_byte
)
382 printchar (ch
, printcharfun
);
387 while (i
< size_byte
)
389 /* Here, we must convert each multi-byte form to the
390 corresponding character code before handing it to
393 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
395 printchar (ch
, printcharfun
);
402 /* Print the contents of a string STRING using PRINTCHARFUN.
403 It isn't safe to use strout in many cases,
404 because printing one char can relocate. */
407 print_string (Lisp_Object string
, Lisp_Object printcharfun
)
409 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
413 if (print_escape_nonascii
)
414 string
= string_escape_byte8 (string
);
416 if (STRING_MULTIBYTE (string
))
417 chars
= SCHARS (string
);
418 else if (! print_escape_nonascii
419 && (EQ (printcharfun
, Qt
)
420 ? ! NILP (BVAR (&buffer_defaults
, enable_multibyte_characters
))
421 : ! NILP (BVAR (current_buffer
, enable_multibyte_characters
))))
423 /* If unibyte string STRING contains 8-bit codes, we must
424 convert STRING to a multibyte string containing the same
429 chars
= SBYTES (string
);
430 bytes
= count_size_as_multibyte (SDATA (string
), chars
);
433 newstr
= make_uninit_multibyte_string (chars
, bytes
);
434 memcpy (SDATA (newstr
), SDATA (string
), chars
);
435 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
440 chars
= SBYTES (string
);
442 if (EQ (printcharfun
, Qt
))
444 /* Output to echo area. */
445 ptrdiff_t nbytes
= SBYTES (string
);
447 /* Copy the string contents so that relocation of STRING by
448 GC does not cause trouble. */
450 char *buffer
= SAFE_ALLOCA (nbytes
);
451 memcpy (buffer
, SDATA (string
), nbytes
);
453 strout (buffer
, chars
, nbytes
, printcharfun
);
458 /* No need to copy, since output to print_buffer can't GC. */
459 strout (SSDATA (string
), chars
, SBYTES (string
), printcharfun
);
463 /* Otherwise, string may be relocated by printing one char.
464 So re-fetch the string address for each character. */
466 ptrdiff_t size
= SCHARS (string
);
467 ptrdiff_t size_byte
= SBYTES (string
);
468 if (size
== size_byte
)
469 for (i
= 0; i
< size
; i
++)
470 printchar (SREF (string
, i
), printcharfun
);
472 for (i
= 0; i
< size_byte
; )
474 /* Here, we must convert each multi-byte form to the
475 corresponding character code before handing it to PRINTCHAR. */
477 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
, len
);
478 printchar (ch
, printcharfun
);
484 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
485 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
486 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
487 (Lisp_Object character
, Lisp_Object printcharfun
)
489 if (NILP (printcharfun
))
490 printcharfun
= Vstandard_output
;
491 CHECK_NUMBER (character
);
493 printchar (XINT (character
), printcharfun
);
498 /* Print the contents of a unibyte C string STRING using PRINTCHARFUN.
499 The caller should arrange to put this inside PRINTPREPARE and PRINTFINISH.
500 Do not use this on the contents of a Lisp string. */
503 print_c_string (char const *string
, Lisp_Object printcharfun
)
505 ptrdiff_t len
= strlen (string
);
506 strout (string
, len
, len
, printcharfun
);
509 /* Print unibyte C string at DATA on a specified stream PRINTCHARFUN.
510 Do not use this on the contents of a Lisp string. */
513 write_string_1 (const char *data
, Lisp_Object printcharfun
)
516 print_c_string (data
, printcharfun
);
520 /* Used from outside of print.c to print a C unibyte
521 string at DATA on the default output stream.
522 Do not use this on the contents of a Lisp string. */
525 write_string (const char *data
)
527 write_string_1 (data
, Vstandard_output
);
532 temp_output_buffer_setup (const char *bufname
)
534 ptrdiff_t count
= SPECPDL_INDEX ();
535 register struct buffer
*old
= current_buffer
;
536 register Lisp_Object buf
;
538 record_unwind_current_buffer ();
540 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
542 Fkill_all_local_variables ();
543 delete_all_overlays (current_buffer
);
544 bset_directory (current_buffer
, BVAR (old
, directory
));
545 bset_read_only (current_buffer
, Qnil
);
546 bset_filename (current_buffer
, Qnil
);
547 bset_undo_list (current_buffer
, Qt
);
548 eassert (current_buffer
->overlays_before
== NULL
);
549 eassert (current_buffer
->overlays_after
== NULL
);
550 bset_enable_multibyte_characters
551 (current_buffer
, BVAR (&buffer_defaults
, enable_multibyte_characters
));
552 specbind (Qinhibit_read_only
, Qt
);
553 specbind (Qinhibit_modification_hooks
, Qt
);
555 XSETBUFFER (buf
, current_buffer
);
557 run_hook (Qtemp_buffer_setup_hook
);
559 unbind_to (count
, Qnil
);
561 specbind (Qstandard_output
, buf
);
564 static void print (Lisp_Object
, Lisp_Object
, bool);
565 static void print_preprocess (Lisp_Object
);
566 static void print_preprocess_string (INTERVAL
, Lisp_Object
);
567 static void print_object (Lisp_Object
, Lisp_Object
, bool);
569 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 2, 0,
570 doc
: /* Output a newline to stream PRINTCHARFUN.
571 If ENSURE is non-nil only output a newline if not already at the
572 beginning of a line. Value is non-nil if a newline is printed.
573 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
574 (Lisp_Object printcharfun
, Lisp_Object ensure
)
578 if (NILP (printcharfun
))
579 printcharfun
= Vstandard_output
;
584 /* Difficult to check if at line beginning so abort. */
585 else if (FUNCTIONP (printcharfun
))
586 signal_error ("Unsupported function argument", printcharfun
);
587 else if (noninteractive
&& !NILP (printcharfun
))
588 val
= printchar_stdout_last
== 10 ? Qnil
: Qt
;
590 val
= NILP (Fbolp ()) ? Qt
: Qnil
;
593 printchar ('\n', printcharfun
);
598 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
599 doc
: /* Output the printed representation of OBJECT, any Lisp object.
600 Quoting characters are printed when needed to make output that `read'
601 can handle, whenever this is possible. For complex objects, the behavior
602 is controlled by `print-level' and `print-length', which see.
604 OBJECT is any of the Lisp data types: a number, a string, a symbol,
605 a list, a buffer, a window, a frame, etc.
607 A printed representation of an object is text which describes that object.
609 Optional argument PRINTCHARFUN is the output stream, which can be one
612 - a buffer, in which case output is inserted into that buffer at point;
613 - a marker, in which case output is inserted at marker's position;
614 - a function, in which case that function is called once for each
615 character of OBJECT's printed representation;
616 - a symbol, in which case that symbol's function definition is called; or
617 - t, in which case the output is displayed in the echo area.
619 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
621 (Lisp_Object object
, Lisp_Object printcharfun
)
623 if (NILP (printcharfun
))
624 printcharfun
= Vstandard_output
;
626 print (object
, printcharfun
, 1);
631 /* a buffer which is used to hold output being built by prin1-to-string */
632 Lisp_Object Vprin1_to_string_buffer
;
634 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
635 doc
: /* Return a string containing the printed representation of OBJECT.
636 OBJECT can be any Lisp object. This function outputs quoting characters
637 when necessary to make output that `read' can handle, whenever possible,
638 unless the optional second argument NOESCAPE is non-nil. For complex objects,
639 the behavior is controlled by `print-level' and `print-length', which see.
641 OBJECT is any of the Lisp data types: a number, a string, a symbol,
642 a list, a buffer, a window, a frame, etc.
644 A printed representation of an object is text which describes that object. */)
645 (Lisp_Object object
, Lisp_Object noescape
)
647 ptrdiff_t count
= SPECPDL_INDEX ();
649 specbind (Qinhibit_modification_hooks
, Qt
);
651 /* Save and restore this: we are altering a buffer
652 but we don't want to deactivate the mark just for that.
653 No need for specbind, since errors deactivate the mark. */
654 Lisp_Object save_deactivate_mark
= Vdeactivate_mark
;
655 bool prev_abort_on_gc
= abort_on_gc
;
658 Lisp_Object printcharfun
= Vprin1_to_string_buffer
;
660 print (object
, printcharfun
, NILP (noescape
));
661 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINISH */
664 struct buffer
*previous
= current_buffer
;
665 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
666 object
= Fbuffer_string ();
667 if (SBYTES (object
) == SCHARS (object
))
668 STRING_SET_UNIBYTE (object
);
670 /* Note that this won't make prepare_to_modify_buffer call
671 ask-user-about-supersession-threat because this buffer
672 does not visit a file. */
674 set_buffer_internal (previous
);
676 Vdeactivate_mark
= save_deactivate_mark
;
678 abort_on_gc
= prev_abort_on_gc
;
679 return unbind_to (count
, object
);
682 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
683 doc
: /* Output the printed representation of OBJECT, any Lisp object.
684 No quoting characters are used; no delimiters are printed around
685 the contents of strings.
687 OBJECT is any of the Lisp data types: a number, a string, a symbol,
688 a list, a buffer, a window, a frame, etc.
690 A printed representation of an object is text which describes that object.
692 Optional argument PRINTCHARFUN is the output stream, which can be one
695 - a buffer, in which case output is inserted into that buffer at point;
696 - a marker, in which case output is inserted at marker's position;
697 - a function, in which case that function is called once for each
698 character of OBJECT's printed representation;
699 - a symbol, in which case that symbol's function definition is called; or
700 - t, in which case the output is displayed in the echo area.
702 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
704 (Lisp_Object object
, Lisp_Object printcharfun
)
706 if (NILP (printcharfun
))
707 printcharfun
= Vstandard_output
;
709 print (object
, printcharfun
, 0);
714 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
715 doc
: /* Output the printed representation of OBJECT, with newlines around it.
716 Quoting characters are printed when needed to make output that `read'
717 can handle, whenever this is possible. For complex objects, the behavior
718 is controlled by `print-level' and `print-length', which see.
720 OBJECT is any of the Lisp data types: a number, a string, a symbol,
721 a list, a buffer, a window, a frame, etc.
723 A printed representation of an object is text which describes that object.
725 Optional argument PRINTCHARFUN is the output stream, which can be one
728 - a buffer, in which case output is inserted into that buffer at point;
729 - a marker, in which case output is inserted at marker's position;
730 - a function, in which case that function is called once for each
731 character of OBJECT's printed representation;
732 - a symbol, in which case that symbol's function definition is called; or
733 - t, in which case the output is displayed in the echo area.
735 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
737 (Lisp_Object object
, Lisp_Object printcharfun
)
739 if (NILP (printcharfun
))
740 printcharfun
= Vstandard_output
;
742 printchar ('\n', printcharfun
);
743 print (object
, printcharfun
, 1);
744 printchar ('\n', printcharfun
);
749 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
750 doc
: /* Write CHARACTER to stderr.
751 You can call print while debugging emacs, and pass it this function
752 to make it write to the debugging output. */)
753 (Lisp_Object character
)
755 CHECK_NUMBER (character
);
756 printchar_to_stream (XINT (character
), stderr
);
760 /* This function is never called. Its purpose is to prevent
761 print_output_debug_flag from being optimized away. */
763 extern void debug_output_compilation_hack (bool) EXTERNALLY_VISIBLE
;
765 debug_output_compilation_hack (bool x
)
767 print_output_debug_flag
= x
;
770 #if defined (GNU_LINUX)
772 /* This functionality is not vitally important in general, so we rely on
773 non-portable ability to use stderr as lvalue. */
775 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
777 static FILE *initial_stderr_stream
= NULL
;
779 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
781 "FDebug output file: \nP",
782 doc
: /* Redirect debugging output (stderr stream) to file FILE.
783 If FILE is nil, reset target to the initial stderr stream.
784 Optional arg APPEND non-nil (interactively, with prefix arg) means
785 append to existing target file. */)
786 (Lisp_Object file
, Lisp_Object append
)
788 if (initial_stderr_stream
!= NULL
)
794 stderr
= initial_stderr_stream
;
795 initial_stderr_stream
= NULL
;
799 file
= Fexpand_file_name (file
, Qnil
);
800 initial_stderr_stream
= stderr
;
801 stderr
= emacs_fopen (SSDATA (file
), NILP (append
) ? "w" : "a");
804 stderr
= initial_stderr_stream
;
805 initial_stderr_stream
= NULL
;
806 report_file_error ("Cannot open debugging output stream", file
);
811 #endif /* GNU_LINUX */
814 /* This is the interface for debugging printing. */
817 debug_print (Lisp_Object arg
)
819 Fprin1 (arg
, Qexternal_debugging_output
);
820 fprintf (stderr
, "\r\n");
823 void safe_debug_print (Lisp_Object
) EXTERNALLY_VISIBLE
;
825 safe_debug_print (Lisp_Object arg
)
827 int valid
= valid_lisp_object_p (arg
);
833 EMACS_UINT n
= XLI (arg
);
834 fprintf (stderr
, "#<%s_LISP_OBJECT 0x%08"pI
"x>\r\n",
835 !valid
? "INVALID" : "SOME",
841 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
843 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
844 See Info anchor `(elisp)Definition of signal' for some details on how this
845 error message is constructed. */)
848 struct buffer
*old
= current_buffer
;
851 /* If OBJ is (error STRING), just return STRING.
852 That is not only faster, it also avoids the need to allocate
853 space here when the error is due to memory full. */
854 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
855 && CONSP (XCDR (obj
))
856 && STRINGP (XCAR (XCDR (obj
)))
857 && NILP (XCDR (XCDR (obj
))))
858 return XCAR (XCDR (obj
));
860 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
862 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
863 value
= Fbuffer_string ();
866 set_buffer_internal (old
);
871 /* Print an error message for the error DATA onto Lisp output stream
872 STREAM (suitable for the print functions).
873 CONTEXT is a C string describing the context of the error.
874 CALLER is the Lisp function inside which the error was signaled. */
877 print_error_message (Lisp_Object data
, Lisp_Object stream
, const char *context
,
880 Lisp_Object errname
, errmsg
, file_error
, tail
;
883 write_string_1 (context
, stream
);
885 /* If we know from where the error was signaled, show it in
887 if (!NILP (caller
) && SYMBOLP (caller
))
889 Lisp_Object cname
= SYMBOL_NAME (caller
);
890 ptrdiff_t cnamelen
= SBYTES (cname
);
892 char *name
= SAFE_ALLOCA (cnamelen
);
893 memcpy (name
, SDATA (cname
), cnamelen
);
894 message_dolog (name
, cnamelen
, 0, STRING_MULTIBYTE (cname
));
895 message_dolog (": ", 2, 0, 0);
899 errname
= Fcar (data
);
901 if (EQ (errname
, Qerror
))
906 errmsg
= Fcar (data
);
911 Lisp_Object error_conditions
= Fget (errname
, Qerror_conditions
);
912 errmsg
= Fget (errname
, Qerror_message
);
913 file_error
= Fmemq (Qfile_error
, error_conditions
);
916 /* Print an error message including the data items. */
918 tail
= Fcdr_safe (data
);
920 /* For file-error, make error message by concatenating
921 all the data items. They are all strings. */
922 if (!NILP (file_error
) && CONSP (tail
))
923 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
926 const char *sep
= ": ";
928 if (!STRINGP (errmsg
))
929 write_string_1 ("peculiar error", stream
);
930 else if (SCHARS (errmsg
))
931 Fprinc (Fsubstitute_command_keys (errmsg
), stream
);
935 for (; CONSP (tail
); tail
= XCDR (tail
), sep
= ", ")
940 write_string_1 (sep
, stream
);
942 if (!NILP (file_error
)
943 || EQ (errname
, Qend_of_file
) || EQ (errname
, Quser_error
))
944 Fprinc (obj
, stream
);
946 Fprin1 (obj
, stream
);
954 * The buffer should be at least as large as the max string size of the
955 * largest float, printed in the biggest notation. This is undoubtedly
956 * 20d float_output_format, with the negative of the C-constant "HUGE"
959 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
961 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
962 * case of -1e307 in 20d float_output_format. What is one to do (short of
963 * re-writing _doprnt to be more sane)?
965 * Given the above, the buffer must be least FLOAT_TO_STRING_BUFSIZE bytes.
969 float_to_string (char *buf
, double data
)
975 /* Check for plus infinity in a way that won't lose
976 if there is no plus infinity. */
977 if (data
== data
/ 2 && data
> 1.0)
979 static char const infinity_string
[] = "1.0e+INF";
980 strcpy (buf
, infinity_string
);
981 return sizeof infinity_string
- 1;
983 /* Likewise for minus infinity. */
984 if (data
== data
/ 2 && data
< -1.0)
986 static char const minus_infinity_string
[] = "-1.0e+INF";
987 strcpy (buf
, minus_infinity_string
);
988 return sizeof minus_infinity_string
- 1;
990 /* Check for NaN in a way that won't fail if there are no NaNs. */
991 if (! (data
* 0.0 >= 0.0))
993 /* Prepend "-" if the NaN's sign bit is negative.
994 The sign bit of a double is the bit that is 1 in -0.0. */
995 static char const NaN_string
[] = "0.0e+NaN";
997 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
1000 u_minus_zero
.d
= - 0.0;
1001 for (i
= 0; i
< sizeof (double); i
++)
1002 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
1009 strcpy (buf
+ negative
, NaN_string
);
1010 return negative
+ sizeof NaN_string
- 1;
1013 if (NILP (Vfloat_output_format
)
1014 || !STRINGP (Vfloat_output_format
))
1017 /* Generate the fewest number of digits that represent the
1018 floating point value without losing information. */
1019 len
= dtoastr (buf
, FLOAT_TO_STRING_BUFSIZE
- 2, 0, 0, data
);
1020 /* The decimal point must be printed, or the byte compiler can
1021 get confused (Bug#8033). */
1024 else /* oink oink */
1026 /* Check that the spec we have is fully valid.
1027 This means not only valid for printf,
1028 but meant for floats, and reasonable. */
1029 cp
= SSDATA (Vfloat_output_format
);
1038 /* Check the width specification. */
1040 if ('0' <= *cp
&& *cp
<= '9')
1045 width
= (width
* 10) + (*cp
++ - '0');
1046 if (DBL_DIG
< width
)
1049 while (*cp
>= '0' && *cp
<= '9');
1051 /* A precision of zero is valid only for %f. */
1052 if (width
== 0 && *cp
!= 'f')
1056 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1062 len
= sprintf (buf
, SSDATA (Vfloat_output_format
), data
);
1065 /* Make sure there is a decimal point with digit after, or an
1066 exponent, so that the value is readable as a float. But don't do
1067 this with "%.0f"; it's valid for that not to produce a decimal
1068 point. Note that width can be 0 only for %.0f. */
1071 for (cp
= buf
; *cp
; cp
++)
1072 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1075 if (*cp
== '.' && cp
[1] == 0)
1095 print (Lisp_Object obj
, Lisp_Object printcharfun
, bool escapeflag
)
1097 new_backquote_output
= 0;
1099 /* Reset print_number_index and Vprint_number_table only when
1100 the variable Vprint_continuous_numbering is nil. Otherwise,
1101 the values of these variables will be kept between several
1103 if (NILP (Vprint_continuous_numbering
)
1104 || NILP (Vprint_number_table
))
1106 print_number_index
= 0;
1107 Vprint_number_table
= Qnil
;
1110 /* Construct Vprint_number_table for print-gensym and print-circle. */
1111 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1113 /* Construct Vprint_number_table.
1114 This increments print_number_index for the objects added. */
1116 print_preprocess (obj
);
1118 if (HASH_TABLE_P (Vprint_number_table
))
1119 { /* Remove unnecessary objects, which appear only once in OBJ;
1120 that is, whose status is Qt. */
1121 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vprint_number_table
);
1124 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
1125 if (!NILP (HASH_HASH (h
, i
))
1126 && EQ (HASH_VALUE (h
, i
), Qt
))
1127 Fremhash (HASH_KEY (h
, i
), Vprint_number_table
);
1132 print_object (obj
, printcharfun
, escapeflag
);
1135 #define PRINT_CIRCLE_CANDIDATE_P(obj) \
1136 (STRINGP (obj) || CONSP (obj) \
1137 || (VECTORLIKEP (obj) \
1138 && (VECTORP (obj) || COMPILEDP (obj) \
1139 || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \
1140 || HASH_TABLE_P (obj) || FONTP (obj))) \
1141 || (! NILP (Vprint_gensym) \
1143 && !SYMBOL_INTERNED_P (obj)))
1145 /* Construct Vprint_number_table according to the structure of OBJ.
1146 OBJ itself and all its elements will be added to Vprint_number_table
1147 recursively if it is a list, vector, compiled function, char-table,
1148 string (its text properties will be traced), or a symbol that has
1149 no obarray (this is for the print-gensym feature).
1150 The status fields of Vprint_number_table mean whether each object appears
1151 more than once in OBJ: Qnil at the first time, and Qt after that. */
1153 print_preprocess (Lisp_Object obj
)
1158 Lisp_Object halftail
;
1160 /* Avoid infinite recursion for circular nested structure
1161 in the case where Vprint_circle is nil. */
1162 if (NILP (Vprint_circle
))
1164 /* Give up if we go so deep that print_object will get an error. */
1165 /* See similar code in print_object. */
1166 if (print_depth
>= PRINT_CIRCLE
)
1167 error ("Apparently circular structure being printed");
1169 for (i
= 0; i
< print_depth
; i
++)
1170 if (EQ (obj
, being_printed
[i
]))
1172 being_printed
[print_depth
] = obj
;
1179 if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1181 if (!HASH_TABLE_P (Vprint_number_table
))
1182 Vprint_number_table
= CALLN (Fmake_hash_table
, QCtest
, Qeq
);
1184 /* In case print-circle is nil and print-gensym is t,
1185 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1186 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1188 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1190 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1191 always print the gensym with a number. This is a special for
1192 the lisp function byte-compile-output-docform. */
1193 || (!NILP (Vprint_continuous_numbering
)
1195 && !SYMBOL_INTERNED_P (obj
)))
1196 { /* OBJ appears more than once. Let's remember that. */
1197 if (!INTEGERP (num
))
1199 print_number_index
++;
1200 /* Negative number indicates it hasn't been printed yet. */
1201 Fputhash (obj
, make_number (- print_number_index
),
1202 Vprint_number_table
);
1208 /* OBJ is not yet recorded. Let's add to the table. */
1209 Fputhash (obj
, Qt
, Vprint_number_table
);
1212 switch (XTYPE (obj
))
1215 /* A string may have text properties, which can be circular. */
1216 traverse_intervals_noorder (string_intervals (obj
),
1217 print_preprocess_string
, Qnil
);
1221 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1222 just as in print_object. */
1223 if (loop_count
&& EQ (obj
, halftail
))
1225 print_preprocess (XCAR (obj
));
1228 if (!(loop_count
& 1))
1229 halftail
= XCDR (halftail
);
1232 case Lisp_Vectorlike
:
1234 if (size
& PSEUDOVECTOR_FLAG
)
1235 size
&= PSEUDOVECTOR_SIZE_MASK
;
1236 for (i
= (SUB_CHAR_TABLE_P (obj
)
1237 ? SUB_CHAR_TABLE_OFFSET
: 0); i
< size
; i
++)
1238 print_preprocess (AREF (obj
, i
));
1239 if (HASH_TABLE_P (obj
))
1240 { /* For hash tables, the key_and_value slot is past
1241 `size' because it needs to be marked specially in case
1242 the table is weak. */
1243 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1244 print_preprocess (h
->key_and_value
);
1256 print_preprocess_string (INTERVAL interval
, Lisp_Object arg
)
1258 print_preprocess (interval
->plist
);
1261 static void print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
);
1263 #define PRINT_STRING_NON_CHARSET_FOUND 1
1264 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1266 /* Bitwise or of the above macros. */
1267 static int print_check_string_result
;
1270 print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
)
1274 if (NILP (interval
->plist
)
1275 || (print_check_string_result
== (PRINT_STRING_NON_CHARSET_FOUND
1276 | PRINT_STRING_UNSAFE_CHARSET_FOUND
)))
1278 for (val
= interval
->plist
; CONSP (val
) && ! EQ (XCAR (val
), Qcharset
);
1279 val
= XCDR (XCDR (val
)));
1282 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1285 if (! (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
))
1287 if (! EQ (val
, interval
->plist
)
1288 || CONSP (XCDR (XCDR (val
))))
1289 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1291 if (NILP (Vprint_charset_text_property
)
1292 || ! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1295 ptrdiff_t charpos
= interval
->position
;
1296 ptrdiff_t bytepos
= string_char_to_byte (string
, charpos
);
1297 Lisp_Object charset
;
1299 charset
= XCAR (XCDR (val
));
1300 for (i
= 0; i
< LENGTH (interval
); i
++)
1302 FETCH_STRING_CHAR_ADVANCE (c
, string
, charpos
, bytepos
);
1303 if (! ASCII_CHAR_P (c
)
1304 && ! EQ (CHARSET_NAME (CHAR_CHARSET (c
)), charset
))
1306 print_check_string_result
|= PRINT_STRING_UNSAFE_CHARSET_FOUND
;
1313 /* The value is (charset . nil). */
1314 static Lisp_Object print_prune_charset_plist
;
1317 print_prune_string_charset (Lisp_Object string
)
1319 print_check_string_result
= 0;
1320 traverse_intervals (string_intervals (string
), 0,
1321 print_check_string_charset_prop
, string
);
1322 if (! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1324 string
= Fcopy_sequence (string
);
1325 if (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
)
1327 if (NILP (print_prune_charset_plist
))
1328 print_prune_charset_plist
= list1 (Qcharset
);
1329 Fremove_text_properties (make_number (0),
1330 make_number (SCHARS (string
)),
1331 print_prune_charset_plist
, string
);
1334 Fset_text_properties (make_number (0), make_number (SCHARS (string
)),
1341 print_object (Lisp_Object obj
, Lisp_Object printcharfun
, bool escapeflag
)
1343 char buf
[max (sizeof "from..to..in " + 2 * INT_STRLEN_BOUND (EMACS_INT
),
1344 max (sizeof " . #" + INT_STRLEN_BOUND (printmax_t
),
1349 /* Detect circularities and truncate them. */
1350 if (NILP (Vprint_circle
))
1352 /* Simple but incomplete way. */
1355 /* See similar code in print_preprocess. */
1356 if (print_depth
>= PRINT_CIRCLE
)
1357 error ("Apparently circular structure being printed");
1359 for (i
= 0; i
< print_depth
; i
++)
1360 if (EQ (obj
, being_printed
[i
]))
1362 int len
= sprintf (buf
, "#%d", i
);
1363 strout (buf
, len
, len
, printcharfun
);
1366 being_printed
[print_depth
] = obj
;
1368 else if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1370 /* With the print-circle feature. */
1371 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1374 EMACS_INT n
= XINT (num
);
1376 { /* Add a prefix #n= if OBJ has not yet been printed;
1377 that is, its status field is nil. */
1378 int len
= sprintf (buf
, "#%"pI
"d=", -n
);
1379 strout (buf
, len
, len
, printcharfun
);
1380 /* OBJ is going to be printed. Remember that fact. */
1381 Fputhash (obj
, make_number (- n
), Vprint_number_table
);
1385 /* Just print #n# if OBJ has already been printed. */
1386 int len
= sprintf (buf
, "#%"pI
"d#", n
);
1387 strout (buf
, len
, len
, printcharfun
);
1395 switch (XTYPE (obj
))
1399 int len
= sprintf (buf
, "%"pI
"d", XINT (obj
));
1400 strout (buf
, len
, len
, printcharfun
);
1406 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
1407 int len
= float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1408 strout (pigbuf
, len
, len
, printcharfun
);
1414 print_string (obj
, printcharfun
);
1417 ptrdiff_t i
, i_byte
;
1418 ptrdiff_t size_byte
;
1419 /* True means we must ensure that the next character we output
1420 cannot be taken as part of a hex character escape. */
1421 bool need_nonhex
= false;
1422 bool multibyte
= STRING_MULTIBYTE (obj
);
1424 if (! EQ (Vprint_charset_text_property
, Qt
))
1425 obj
= print_prune_string_charset (obj
);
1427 if (string_intervals (obj
))
1428 print_c_string ("#(", printcharfun
);
1430 printchar ('\"', printcharfun
);
1431 size_byte
= SBYTES (obj
);
1433 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1435 /* Here, we must convert each multi-byte form to the
1436 corresponding character code before handing it to printchar. */
1439 FETCH_STRING_CHAR_ADVANCE (c
, obj
, i
, i_byte
);
1444 ? (CHAR_BYTE8_P (c
) && (c
= CHAR_TO_BYTE8 (c
), true))
1445 : (SINGLE_BYTE_CHAR_P (c
) && ! ASCII_CHAR_P (c
)
1446 && print_escape_nonascii
))
1448 /* When printing a raw 8-bit byte in a multibyte buffer, or
1449 (when requested) a non-ASCII character in a unibyte buffer,
1450 print single-byte non-ASCII string chars
1451 using octal escapes. */
1453 int len
= sprintf (outbuf
, "\\%03o", c
+ 0u);
1454 strout (outbuf
, len
, len
, printcharfun
);
1455 need_nonhex
= false;
1458 && ! ASCII_CHAR_P (c
) && print_escape_multibyte
)
1460 /* When requested, print multibyte chars using hex escapes. */
1461 char outbuf
[sizeof "\\x" + INT_STRLEN_BOUND (c
)];
1462 int len
= sprintf (outbuf
, "\\x%04x", c
+ 0u);
1463 strout (outbuf
, len
, len
, printcharfun
);
1468 /* If we just had a hex escape, and this character
1469 could be taken as part of it,
1470 output `\ ' to prevent that. */
1471 if (need_nonhex
&& c_isxdigit (c
))
1472 print_c_string ("\\ ", printcharfun
);
1474 if (c
== '\n' && print_escape_newlines
1476 : c
== '\f' && print_escape_newlines
1478 : c
== '\"' || c
== '\\')
1479 printchar ('\\', printcharfun
);
1481 printchar (c
, printcharfun
);
1482 need_nonhex
= false;
1485 printchar ('\"', printcharfun
);
1487 if (string_intervals (obj
))
1489 traverse_intervals (string_intervals (obj
),
1490 0, print_interval
, printcharfun
);
1491 printchar (')', printcharfun
);
1499 unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1500 unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1502 ptrdiff_t i
, i_byte
;
1503 ptrdiff_t size_byte
;
1506 name
= SYMBOL_NAME (obj
);
1508 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1511 /* If symbol name begins with a digit, and ends with a digit,
1512 and contains nothing but digits and `e', it could be treated
1513 as a number. So set CONFUSING.
1515 Symbols that contain periods could also be taken as numbers,
1516 but periods are always escaped, so we don't have to worry
1518 else if (*p
>= '0' && *p
<= '9'
1519 && end
[-1] >= '0' && end
[-1] <= '9')
1521 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1522 /* Needed for \2e10. */
1523 || *p
== 'e' || *p
== 'E'))
1525 confusing
= (end
== p
);
1530 size_byte
= SBYTES (name
);
1532 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1533 print_c_string ("#:", printcharfun
);
1534 else if (size_byte
== 0)
1536 print_c_string ("##", printcharfun
);
1540 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1542 /* Here, we must convert each multi-byte form to the
1543 corresponding character code before handing it to PRINTCHAR. */
1544 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1549 if (c
== '\"' || c
== '\\' || c
== '\''
1550 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1551 || c
== ',' || c
== '.' || c
== '`'
1552 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1555 printchar ('\\', printcharfun
);
1559 printchar (c
, printcharfun
);
1565 /* If deeper than spec'd depth, print placeholder. */
1566 if (INTEGERP (Vprint_level
)
1567 && print_depth
> XINT (Vprint_level
))
1568 print_c_string ("...", printcharfun
);
1569 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1570 && EQ (XCAR (obj
), Qquote
))
1572 printchar ('\'', printcharfun
);
1573 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1575 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1576 && EQ (XCAR (obj
), Qfunction
))
1578 print_c_string ("#'", printcharfun
);
1579 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1581 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1582 && EQ (XCAR (obj
), Qbackquote
))
1584 printchar ('`', printcharfun
);
1585 new_backquote_output
++;
1586 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1587 new_backquote_output
--;
1589 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1590 && new_backquote_output
1591 && (EQ (XCAR (obj
), Qcomma
)
1592 || EQ (XCAR (obj
), Qcomma_at
)
1593 || EQ (XCAR (obj
), Qcomma_dot
)))
1595 print_object (XCAR (obj
), printcharfun
, false);
1596 new_backquote_output
--;
1597 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1598 new_backquote_output
++;
1602 printchar ('(', printcharfun
);
1604 Lisp_Object halftail
= obj
;
1606 /* Negative values of print-length are invalid in CL.
1607 Treat them like nil, as CMUCL does. */
1608 printmax_t print_length
= (NATNUMP (Vprint_length
)
1609 ? XFASTINT (Vprint_length
)
1610 : TYPE_MAXIMUM (printmax_t
));
1615 /* Detect circular list. */
1616 if (NILP (Vprint_circle
))
1618 /* Simple but incomplete way. */
1619 if (i
!= 0 && EQ (obj
, halftail
))
1621 int len
= sprintf (buf
, " . #%"pMd
, i
/ 2);
1622 strout (buf
, len
, len
, printcharfun
);
1628 /* With the print-circle feature. */
1631 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1634 print_c_string (" . ", printcharfun
);
1635 print_object (obj
, printcharfun
, escapeflag
);
1642 printchar (' ', printcharfun
);
1644 if (print_length
<= i
)
1646 print_c_string ("...", printcharfun
);
1651 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1655 halftail
= XCDR (halftail
);
1658 /* OBJ non-nil here means it's the end of a dotted list. */
1661 print_c_string (" . ", printcharfun
);
1662 print_object (obj
, printcharfun
, escapeflag
);
1666 printchar (')', printcharfun
);
1670 case Lisp_Vectorlike
:
1675 print_c_string ("#<process ", printcharfun
);
1676 print_string (XPROCESS (obj
)->name
, printcharfun
);
1677 printchar ('>', printcharfun
);
1680 print_string (XPROCESS (obj
)->name
, printcharfun
);
1682 else if (BOOL_VECTOR_P (obj
))
1686 EMACS_INT size
= bool_vector_size (obj
);
1687 ptrdiff_t size_in_chars
= bool_vector_bytes (size
);
1688 ptrdiff_t real_size_in_chars
= size_in_chars
;
1690 int len
= sprintf (buf
, "#&%"pI
"d\"", size
);
1691 strout (buf
, len
, len
, printcharfun
);
1693 /* Don't print more characters than the specified maximum.
1694 Negative values of print-length are invalid. Treat them
1695 like a print-length of nil. */
1696 if (NATNUMP (Vprint_length
)
1697 && XFASTINT (Vprint_length
) < size_in_chars
)
1698 size_in_chars
= XFASTINT (Vprint_length
);
1700 for (i
= 0; i
< size_in_chars
; i
++)
1703 c
= bool_vector_uchar_data (obj
)[i
];
1704 if (c
== '\n' && print_escape_newlines
)
1705 print_c_string ("\\n", printcharfun
);
1706 else if (c
== '\f' && print_escape_newlines
)
1707 print_c_string ("\\f", printcharfun
);
1708 else if (c
> '\177')
1710 /* Use octal escapes to avoid encoding issues. */
1711 len
= sprintf (buf
, "\\%o", c
);
1712 strout (buf
, len
, len
, printcharfun
);
1716 if (c
== '\"' || c
== '\\')
1717 printchar ('\\', printcharfun
);
1718 printchar (c
, printcharfun
);
1722 if (size_in_chars
< real_size_in_chars
)
1723 print_c_string (" ...", printcharfun
);
1724 printchar ('\"', printcharfun
);
1726 else if (SUBRP (obj
))
1728 print_c_string ("#<subr ", printcharfun
);
1729 print_c_string (XSUBR (obj
)->symbol_name
, printcharfun
);
1730 printchar ('>', printcharfun
);
1732 else if (WINDOWP (obj
))
1734 int len
= sprintf (buf
, "#<window %"pI
"d",
1735 XWINDOW (obj
)->sequence_number
);
1736 strout (buf
, len
, len
, printcharfun
);
1737 if (BUFFERP (XWINDOW (obj
)->contents
))
1739 print_c_string (" on ", printcharfun
);
1740 print_string (BVAR (XBUFFER (XWINDOW (obj
)->contents
), name
),
1743 printchar ('>', printcharfun
);
1745 else if (TERMINALP (obj
))
1747 struct terminal
*t
= XTERMINAL (obj
);
1748 int len
= sprintf (buf
, "#<terminal %d", t
->id
);
1749 strout (buf
, len
, len
, printcharfun
);
1752 print_c_string (" on ", printcharfun
);
1753 print_c_string (t
->name
, printcharfun
);
1755 printchar ('>', printcharfun
);
1757 else if (HASH_TABLE_P (obj
))
1759 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1761 ptrdiff_t real_size
, size
;
1765 print_c_string ("#<hash-table", printcharfun
);
1766 if (SYMBOLP (h
->test
))
1768 print_c_string (" '", printcharfun
);
1769 print_c_string (SSDATA (SYMBOL_NAME (h
->test
)), printcharfun
);
1770 printchar (' ', printcharfun
);
1771 print_c_string (SSDATA (SYMBOL_NAME (h
->weak
)), printcharfun
);
1772 len
= sprintf (buf
, " %"pD
"d/%"pD
"d", h
->count
, ASIZE (h
->next
));
1773 strout (buf
, len
, len
, printcharfun
);
1775 len
= sprintf (buf
, " %p>", ptr
);
1776 strout (buf
, len
, len
, printcharfun
);
1778 /* Implement a readable output, e.g.:
1779 #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
1780 /* Always print the size. */
1781 len
= sprintf (buf
, "#s(hash-table size %"pD
"d", ASIZE (h
->next
));
1782 strout (buf
, len
, len
, printcharfun
);
1784 if (!NILP (h
->test
.name
))
1786 print_c_string (" test ", printcharfun
);
1787 print_object (h
->test
.name
, printcharfun
, escapeflag
);
1790 if (!NILP (h
->weak
))
1792 print_c_string (" weakness ", printcharfun
);
1793 print_object (h
->weak
, printcharfun
, escapeflag
);
1796 if (!NILP (h
->rehash_size
))
1798 print_c_string (" rehash-size ", printcharfun
);
1799 print_object (h
->rehash_size
, printcharfun
, escapeflag
);
1802 if (!NILP (h
->rehash_threshold
))
1804 print_c_string (" rehash-threshold ", printcharfun
);
1805 print_object (h
->rehash_threshold
, printcharfun
, escapeflag
);
1808 print_c_string (" data ", printcharfun
);
1810 /* Print the data here as a plist. */
1811 real_size
= HASH_TABLE_SIZE (h
);
1814 /* Don't print more elements than the specified maximum. */
1815 if (NATNUMP (Vprint_length
)
1816 && XFASTINT (Vprint_length
) < size
)
1817 size
= XFASTINT (Vprint_length
);
1819 printchar ('(', printcharfun
);
1820 for (i
= 0; i
< size
; i
++)
1821 if (!NILP (HASH_HASH (h
, i
)))
1823 if (i
) printchar (' ', printcharfun
);
1824 print_object (HASH_KEY (h
, i
), printcharfun
, escapeflag
);
1825 printchar (' ', printcharfun
);
1826 print_object (HASH_VALUE (h
, i
), printcharfun
, escapeflag
);
1829 if (size
< real_size
)
1830 print_c_string (" ...", printcharfun
);
1832 print_c_string ("))", printcharfun
);
1835 else if (BUFFERP (obj
))
1837 if (!BUFFER_LIVE_P (XBUFFER (obj
)))
1838 print_c_string ("#<killed buffer>", printcharfun
);
1839 else if (escapeflag
)
1841 print_c_string ("#<buffer ", printcharfun
);
1842 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1843 printchar ('>', printcharfun
);
1846 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1848 else if (WINDOW_CONFIGURATIONP (obj
))
1849 print_c_string ("#<window-configuration>", printcharfun
);
1850 else if (FRAMEP (obj
))
1853 void *ptr
= XFRAME (obj
);
1854 Lisp_Object frame_name
= XFRAME (obj
)->name
;
1856 print_c_string ((FRAME_LIVE_P (XFRAME (obj
))
1860 if (!STRINGP (frame_name
))
1862 /* A frame could be too young and have no name yet;
1864 if (SYMBOLP (frame_name
))
1865 frame_name
= Fsymbol_name (frame_name
);
1866 else /* can't happen: name should be either nil or string */
1867 frame_name
= build_string ("*INVALID*FRAME*NAME*");
1869 print_string (frame_name
, printcharfun
);
1870 len
= sprintf (buf
, " %p>", ptr
);
1871 strout (buf
, len
, len
, printcharfun
);
1873 else if (FONTP (obj
))
1877 if (! FONT_OBJECT_P (obj
))
1879 if (FONT_SPEC_P (obj
))
1880 print_c_string ("#<font-spec", printcharfun
);
1882 print_c_string ("#<font-entity", printcharfun
);
1883 for (i
= 0; i
< FONT_SPEC_MAX
; i
++)
1885 printchar (' ', printcharfun
);
1886 if (i
< FONT_WEIGHT_INDEX
|| i
> FONT_WIDTH_INDEX
)
1887 print_object (AREF (obj
, i
), printcharfun
, escapeflag
);
1889 print_object (font_style_symbolic (obj
, i
, 0),
1890 printcharfun
, escapeflag
);
1895 print_c_string ("#<font-object ", printcharfun
);
1896 print_object (AREF (obj
, FONT_NAME_INDEX
), printcharfun
,
1899 printchar ('>', printcharfun
);
1903 ptrdiff_t size
= ASIZE (obj
);
1904 if (COMPILEDP (obj
))
1906 printchar ('#', printcharfun
);
1907 size
&= PSEUDOVECTOR_SIZE_MASK
;
1909 if (CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
))
1911 /* We print a char-table as if it were a vector,
1912 lumping the parent and default slots in with the
1913 character slots. But we add #^ as a prefix. */
1915 /* Make each lowest sub_char_table start a new line.
1916 Otherwise we'll make a line extremely long, which
1917 results in slow redisplay. */
1918 if (SUB_CHAR_TABLE_P (obj
)
1919 && XSUB_CHAR_TABLE (obj
)->depth
== 3)
1920 printchar ('\n', printcharfun
);
1921 print_c_string ("#^", printcharfun
);
1922 if (SUB_CHAR_TABLE_P (obj
))
1923 printchar ('^', printcharfun
);
1924 size
&= PSEUDOVECTOR_SIZE_MASK
;
1926 if (size
& PSEUDOVECTOR_FLAG
)
1929 printchar ('[', printcharfun
);
1931 int i
, idx
= SUB_CHAR_TABLE_P (obj
) ? SUB_CHAR_TABLE_OFFSET
: 0;
1933 ptrdiff_t real_size
= size
;
1935 /* For a sub char-table, print heading non-Lisp data first. */
1936 if (SUB_CHAR_TABLE_P (obj
))
1938 i
= sprintf (buf
, "%d %d", XSUB_CHAR_TABLE (obj
)->depth
,
1939 XSUB_CHAR_TABLE (obj
)->min_char
);
1940 strout (buf
, i
, i
, printcharfun
);
1943 /* Don't print more elements than the specified maximum. */
1944 if (NATNUMP (Vprint_length
)
1945 && XFASTINT (Vprint_length
) < size
)
1946 size
= XFASTINT (Vprint_length
);
1948 for (i
= idx
; i
< size
; i
++)
1950 if (i
) printchar (' ', printcharfun
);
1951 tem
= AREF (obj
, i
);
1952 print_object (tem
, printcharfun
, escapeflag
);
1954 if (size
< real_size
)
1955 print_c_string (" ...", printcharfun
);
1957 printchar (']', printcharfun
);
1962 switch (XMISCTYPE (obj
))
1964 case Lisp_Misc_Marker
:
1965 print_c_string ("#<marker ", printcharfun
);
1966 /* Do you think this is necessary? */
1967 if (XMARKER (obj
)->insertion_type
!= 0)
1968 print_c_string ("(moves after insertion) ", printcharfun
);
1969 if (! XMARKER (obj
)->buffer
)
1970 print_c_string ("in no buffer", printcharfun
);
1973 int len
= sprintf (buf
, "at %"pD
"d in ", marker_position (obj
));
1974 strout (buf
, len
, len
, printcharfun
);
1975 print_string (BVAR (XMARKER (obj
)->buffer
, name
), printcharfun
);
1977 printchar ('>', printcharfun
);
1980 case Lisp_Misc_Overlay
:
1981 print_c_string ("#<overlay ", printcharfun
);
1982 if (! XMARKER (OVERLAY_START (obj
))->buffer
)
1983 print_c_string ("in no buffer", printcharfun
);
1986 int len
= sprintf (buf
, "from %"pD
"d to %"pD
"d in ",
1987 marker_position (OVERLAY_START (obj
)),
1988 marker_position (OVERLAY_END (obj
)));
1989 strout (buf
, len
, len
, printcharfun
);
1990 print_string (BVAR (XMARKER (OVERLAY_START (obj
))->buffer
, name
),
1993 printchar ('>', printcharfun
);
1996 case Lisp_Misc_Finalizer
:
1997 print_c_string ("#<finalizer", printcharfun
);
1998 if (NILP (XFINALIZER (obj
)->function
))
1999 print_c_string (" used", printcharfun
);
2000 printchar ('>', printcharfun
);
2003 /* Remaining cases shouldn't happen in normal usage, but let's
2004 print them anyway for the benefit of the debugger. */
2006 case Lisp_Misc_Free
:
2007 print_c_string ("#<misc free cell>", printcharfun
);
2010 case Lisp_Misc_Save_Value
:
2013 struct Lisp_Save_Value
*v
= XSAVE_VALUE (obj
);
2015 print_c_string ("#<save-value ", printcharfun
);
2017 if (v
->save_type
== SAVE_TYPE_MEMORY
)
2019 ptrdiff_t amount
= v
->data
[1].integer
;
2021 /* valid_lisp_object_p is reliable, so try to print up
2022 to 8 saved objects. This code is rarely used, so
2023 it's OK that valid_lisp_object_p is slow. */
2025 int limit
= min (amount
, 8);
2026 Lisp_Object
*area
= v
->data
[0].pointer
;
2028 i
= sprintf (buf
, "with %"pD
"d objects", amount
);
2029 strout (buf
, i
, i
, printcharfun
);
2031 for (i
= 0; i
< limit
; i
++)
2033 Lisp_Object maybe
= area
[i
];
2034 int valid
= valid_lisp_object_p (maybe
);
2036 printchar (' ', printcharfun
);
2038 print_object (maybe
, printcharfun
, escapeflag
);
2040 print_c_string (valid
< 0 ? "<some>" : "<invalid>",
2043 if (i
== limit
&& i
< amount
)
2044 print_c_string (" ...", printcharfun
);
2048 /* Print each slot according to its type. */
2050 for (index
= 0; index
< SAVE_VALUE_SLOTS
; index
++)
2053 printchar (' ', printcharfun
);
2055 switch (save_type (v
, index
))
2058 i
= sprintf (buf
, "<unused>");
2062 i
= sprintf (buf
, "<pointer %p>",
2063 v
->data
[index
].pointer
);
2066 case SAVE_FUNCPOINTER
:
2067 i
= sprintf (buf
, "<funcpointer %p>",
2068 ((void *) (intptr_t)
2069 v
->data
[index
].funcpointer
));
2073 i
= sprintf (buf
, "<integer %"pD
"d>",
2074 v
->data
[index
].integer
);
2078 print_object (v
->data
[index
].object
, printcharfun
,
2086 strout (buf
, i
, i
, printcharfun
);
2089 printchar ('>', printcharfun
);
2102 /* We're in trouble if this happens!
2103 Probably should just emacs_abort (). */
2104 print_c_string ("#<EMACS BUG: INVALID DATATYPE ", printcharfun
);
2106 len
= sprintf (buf
, "(MISC 0x%04x)", (unsigned) XMISCTYPE (obj
));
2107 else if (VECTORLIKEP (obj
))
2108 len
= sprintf (buf
, "(PVEC 0x%08zx)", (size_t) ASIZE (obj
));
2110 len
= sprintf (buf
, "(0x%02x)", (unsigned) XTYPE (obj
));
2111 strout (buf
, len
, len
, printcharfun
);
2112 print_c_string ((" Save your buffers immediately"
2113 " and please report this bug>"),
2122 /* Print a description of INTERVAL using PRINTCHARFUN.
2123 This is part of printing a string that has text properties. */
2126 print_interval (INTERVAL interval
, Lisp_Object printcharfun
)
2128 if (NILP (interval
->plist
))
2130 printchar (' ', printcharfun
);
2131 print_object (make_number (interval
->position
), printcharfun
, 1);
2132 printchar (' ', printcharfun
);
2133 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2135 printchar (' ', printcharfun
);
2136 print_object (interval
->plist
, printcharfun
, 1);
2139 /* Initialize debug_print stuff early to have it working from the very
2143 init_print_once (void)
2145 /* The subroutine object for external-debugging-output is kept here
2146 for the convenience of the debugger. */
2147 DEFSYM (Qexternal_debugging_output
, "external-debugging-output");
2149 defsubr (&Sexternal_debugging_output
);
2153 syms_of_print (void)
2155 DEFSYM (Qtemp_buffer_setup_hook
, "temp-buffer-setup-hook");
2157 DEFVAR_LISP ("standard-output", Vstandard_output
,
2158 doc
: /* Output stream `print' uses by default for outputting a character.
2159 This may be any function of one argument.
2160 It may also be a buffer (output is inserted before point)
2161 or a marker (output is inserted and the marker is advanced)
2162 or the symbol t (output appears in the echo area). */);
2163 Vstandard_output
= Qt
;
2164 DEFSYM (Qstandard_output
, "standard-output");
2166 DEFVAR_LISP ("float-output-format", Vfloat_output_format
,
2167 doc
: /* The format descriptor string used to print floats.
2168 This is a %-spec like those accepted by `printf' in C,
2169 but with some restrictions. It must start with the two characters `%.'.
2170 After that comes an integer precision specification,
2171 and then a letter which controls the format.
2172 The letters allowed are `e', `f' and `g'.
2173 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2174 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2175 Use `g' to choose the shorter of those two formats for the number at hand.
2176 The precision in any of these cases is the number of digits following
2177 the decimal point. With `f', a precision of 0 means to omit the
2178 decimal point. 0 is not allowed with `e' or `g'.
2180 A value of nil means to use the shortest notation
2181 that represents the number without losing information. */);
2182 Vfloat_output_format
= Qnil
;
2184 DEFVAR_LISP ("print-length", Vprint_length
,
2185 doc
: /* Maximum length of list to print before abbreviating.
2186 A value of nil means no limit. See also `eval-expression-print-length'. */);
2187 Vprint_length
= Qnil
;
2189 DEFVAR_LISP ("print-level", Vprint_level
,
2190 doc
: /* Maximum depth of list nesting to print before abbreviating.
2191 A value of nil means no limit. See also `eval-expression-print-level'. */);
2192 Vprint_level
= Qnil
;
2194 DEFVAR_BOOL ("print-escape-newlines", print_escape_newlines
,
2195 doc
: /* Non-nil means print newlines in strings as `\\n'.
2196 Also print formfeeds as `\\f'. */);
2197 print_escape_newlines
= 0;
2199 DEFVAR_BOOL ("print-escape-nonascii", print_escape_nonascii
,
2200 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2201 (OOO is the octal representation of the character code.)
2202 Only single-byte characters are affected, and only in `prin1'.
2203 When the output goes in a multibyte buffer, this feature is
2204 enabled regardless of the value of the variable. */);
2205 print_escape_nonascii
= 0;
2207 DEFVAR_BOOL ("print-escape-multibyte", print_escape_multibyte
,
2208 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2209 (XXXX is the hex representation of the character code.)
2210 This affects only `prin1'. */);
2211 print_escape_multibyte
= 0;
2213 DEFVAR_BOOL ("print-quoted", print_quoted
,
2214 doc
: /* Non-nil means print quoted forms with reader syntax.
2215 I.e., (quote foo) prints as \\='foo, (function foo) as #\\='foo. */);
2218 DEFVAR_LISP ("print-gensym", Vprint_gensym
,
2219 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2220 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2221 When the uninterned symbol appears within a recursive data structure,
2222 and the symbol appears more than once, in addition use the #N# and #N=
2223 constructs as needed, so that multiple references to the same symbol are
2224 shared once again when the text is read back. */);
2225 Vprint_gensym
= Qnil
;
2227 DEFVAR_LISP ("print-circle", Vprint_circle
,
2228 doc
: /* Non-nil means print recursive structures using #N= and #N# syntax.
2229 If nil, printing proceeds recursively and may lead to
2230 `max-lisp-eval-depth' being exceeded or an error may occur:
2231 \"Apparently circular structure being printed.\" Also see
2232 `print-length' and `print-level'.
2233 If non-nil, shared substructures anywhere in the structure are printed
2234 with `#N=' before the first occurrence (in the order of the print
2235 representation) and `#N#' in place of each subsequent occurrence,
2236 where N is a positive decimal integer. */);
2237 Vprint_circle
= Qnil
;
2239 DEFVAR_LISP ("print-continuous-numbering", Vprint_continuous_numbering
,
2240 doc
: /* Non-nil means number continuously across print calls.
2241 This affects the numbers printed for #N= labels and #M# references.
2242 See also `print-circle', `print-gensym', and `print-number-table'.
2243 This variable should not be set with `setq'; bind it with a `let' instead. */);
2244 Vprint_continuous_numbering
= Qnil
;
2246 DEFVAR_LISP ("print-number-table", Vprint_number_table
,
2247 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2248 The Lisp printer uses this vector to detect Lisp objects referenced more
2251 When you bind `print-continuous-numbering' to t, you should probably
2252 also bind `print-number-table' to nil. This ensures that the value of
2253 `print-number-table' can be garbage-collected once the printing is
2254 done. If all elements of `print-number-table' are nil, it means that
2255 the printing done so far has not found any shared structure or objects
2256 that need to be recorded in the table. */);
2257 Vprint_number_table
= Qnil
;
2259 DEFVAR_LISP ("print-charset-text-property", Vprint_charset_text_property
,
2260 doc
: /* A flag to control printing of `charset' text property on printing a string.
2261 The value must be nil, t, or `default'.
2263 If the value is nil, don't print the text property `charset'.
2265 If the value is t, always print the text property `charset'.
2267 If the value is `default', print the text property `charset' only when
2268 the value is different from what is guessed in the current charset
2270 Vprint_charset_text_property
= Qdefault
;
2272 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2273 staticpro (&Vprin1_to_string_buffer
);
2276 defsubr (&Sprin1_to_string
);
2277 defsubr (&Serror_message_string
);
2281 defsubr (&Swrite_char
);
2282 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2283 defsubr (&Sredirect_debugging_output
);
2286 DEFSYM (Qprint_escape_newlines
, "print-escape-newlines");
2287 DEFSYM (Qprint_escape_multibyte
, "print-escape-multibyte");
2288 DEFSYM (Qprint_escape_nonascii
, "print-escape-nonascii");
2290 print_prune_charset_plist
= Qnil
;
2291 staticpro (&print_prune_charset_plist
);