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"
35 #include "intervals.h"
36 #include "blockinput.h"
37 #include "termhooks.h" /* For struct terminal. */
44 /* Avoid actual stack overflow in print. */
45 static ptrdiff_t print_depth
;
47 /* Level of nesting inside outputting backquote in new style. */
48 static ptrdiff_t new_backquote_output
;
50 /* Detect most circularities to print finite output. */
51 #define PRINT_CIRCLE 200
52 static Lisp_Object being_printed
[PRINT_CIRCLE
];
54 /* Last char printed to stdout by printchar. */
55 static unsigned int printchar_stdout_last
;
57 /* When printing into a buffer, first we put the text in this
58 block, then insert it all at once. */
59 static char *print_buffer
;
61 /* Size allocated in print_buffer. */
62 static ptrdiff_t print_buffer_size
;
63 /* Chars stored in print_buffer. */
64 static ptrdiff_t print_buffer_pos
;
65 /* Bytes stored in print_buffer. */
66 static ptrdiff_t print_buffer_pos_byte
;
68 /* Vprint_number_table is a table, that keeps objects that are going to
69 be printed, to allow use of #n= and #n# to express sharing.
70 For any given object, the table can give the following values:
71 t the object will be printed only once.
72 -N the object will be printed several times and will take number N.
73 N the object has been printed so we can refer to it as #N#.
74 print_number_index holds the largest N already used.
75 N has to be striclty larger than 0 since we need to distinguish -N. */
76 static ptrdiff_t print_number_index
;
77 static void print_interval (INTERVAL interval
, Lisp_Object printcharfun
);
79 /* GDB resets this to zero on W32 to disable OutputDebugString calls. */
80 bool print_output_debug_flag EXTERNALLY_VISIBLE
= 1;
83 /* Low level output routines for characters and strings. */
85 /* Lisp functions to do output using a stream
86 must have the stream in a variable called printcharfun
87 and must start with PRINTPREPARE, end with PRINTFINISH.
88 Use printchar to output one character,
89 or call strout to output a block of characters. */
91 #define PRINTPREPARE \
92 struct buffer *old = current_buffer; \
93 ptrdiff_t old_point = -1, start_point = -1; \
94 ptrdiff_t old_point_byte = -1, start_point_byte = -1; \
95 ptrdiff_t specpdl_count = SPECPDL_INDEX (); \
96 bool free_print_buffer = 0; \
98 = !NILP (BVAR (current_buffer, enable_multibyte_characters)); \
99 Lisp_Object original = printcharfun; \
100 if (NILP (printcharfun)) printcharfun = Qt; \
101 if (BUFFERP (printcharfun)) \
103 if (XBUFFER (printcharfun) != current_buffer) \
104 Fset_buffer (printcharfun); \
105 printcharfun = Qnil; \
107 if (MARKERP (printcharfun)) \
109 ptrdiff_t marker_pos; \
110 if (! XMARKER (printcharfun)->buffer) \
111 error ("Marker does not point anywhere"); \
112 if (XMARKER (printcharfun)->buffer != current_buffer) \
113 set_buffer_internal (XMARKER (printcharfun)->buffer); \
114 marker_pos = marker_position (printcharfun); \
115 if (marker_pos < BEGV || marker_pos > ZV) \
116 signal_error ("Marker is outside the accessible " \
117 "part of the buffer", printcharfun); \
119 old_point_byte = PT_BYTE; \
120 SET_PT_BOTH (marker_pos, \
121 marker_byte_position (printcharfun)); \
123 start_point_byte = PT_BYTE; \
124 printcharfun = Qnil; \
126 if (NILP (printcharfun)) \
128 Lisp_Object string; \
129 if (NILP (BVAR (current_buffer, enable_multibyte_characters)) \
130 && ! print_escape_multibyte) \
131 specbind (Qprint_escape_multibyte, Qt); \
132 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)) \
133 && ! print_escape_nonascii) \
134 specbind (Qprint_escape_nonascii, Qt); \
135 if (print_buffer != 0) \
137 string = make_string_from_bytes (print_buffer, \
139 print_buffer_pos_byte); \
140 record_unwind_protect (print_unwind, string); \
144 int new_size = 1000; \
145 print_buffer = xmalloc (new_size); \
146 print_buffer_size = new_size; \
147 free_print_buffer = 1; \
149 print_buffer_pos = 0; \
150 print_buffer_pos_byte = 0; \
152 if (EQ (printcharfun, Qt) && ! noninteractive) \
153 setup_echo_area_for_printing (multibyte);
155 #define PRINTFINISH \
156 if (NILP (printcharfun)) \
158 if (print_buffer_pos != print_buffer_pos_byte \
159 && NILP (BVAR (current_buffer, enable_multibyte_characters)))\
162 unsigned char *temp = SAFE_ALLOCA (print_buffer_pos + 1); \
163 copy_text ((unsigned char *) print_buffer, temp, \
164 print_buffer_pos_byte, 1, 0); \
165 insert_1_both ((char *) temp, print_buffer_pos, \
166 print_buffer_pos, 0, 1, 0); \
170 insert_1_both (print_buffer, print_buffer_pos, \
171 print_buffer_pos_byte, 0, 1, 0); \
172 signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
174 if (free_print_buffer) \
176 xfree (print_buffer); \
179 unbind_to (specpdl_count, Qnil); \
180 if (MARKERP (original)) \
181 set_marker_both (original, Qnil, PT, PT_BYTE); \
182 if (old_point >= 0) \
183 SET_PT_BOTH (old_point + (old_point >= start_point \
184 ? PT - start_point : 0), \
185 old_point_byte + (old_point_byte >= start_point_byte \
186 ? PT_BYTE - start_point_byte : 0)); \
187 set_buffer_internal (old);
189 /* This is used to restore the saved contents of print_buffer
190 when there is a recursive call to print. */
193 print_unwind (Lisp_Object saved_text
)
195 memcpy (print_buffer
, SDATA (saved_text
), SCHARS (saved_text
));
199 /* Print character CH using method FUN. FUN nil means print to
200 print_buffer. FUN t means print to echo area or stdout if
201 non-interactive. If FUN is neither nil nor t, call FUN with CH as
205 printchar (unsigned int ch
, Lisp_Object fun
)
207 if (!NILP (fun
) && !EQ (fun
, Qt
))
208 call1 (fun
, make_number (ch
));
211 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
212 int len
= CHAR_STRING (ch
, str
);
218 ptrdiff_t incr
= len
- (print_buffer_size
- print_buffer_pos_byte
);
220 print_buffer
= xpalloc (print_buffer
, &print_buffer_size
,
222 memcpy (print_buffer
+ print_buffer_pos_byte
, str
, len
);
223 print_buffer_pos
+= 1;
224 print_buffer_pos_byte
+= len
;
226 else if (noninteractive
)
228 printchar_stdout_last
= ch
;
229 fwrite (str
, 1, len
, stdout
);
230 noninteractive_need_newline
= 1;
235 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
237 setup_echo_area_for_printing (multibyte_p
);
239 message_dolog ((char *) str
, len
, 0, multibyte_p
);
245 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
246 method PRINTCHARFUN. PRINTCHARFUN nil means output to
247 print_buffer. PRINTCHARFUN t means output to the echo area or to
248 stdout if non-interactive. If neither nil nor t, call Lisp
249 function PRINTCHARFUN for each character printed. MULTIBYTE
250 non-zero means PTR contains multibyte characters.
252 In the case where PRINTCHARFUN is nil, it is safe for PTR to point
253 to data in a Lisp string. Otherwise that is not safe. */
256 strout (const char *ptr
, ptrdiff_t size
, ptrdiff_t size_byte
,
257 Lisp_Object printcharfun
)
259 if (NILP (printcharfun
))
261 ptrdiff_t incr
= size_byte
- (print_buffer_size
- print_buffer_pos_byte
);
263 print_buffer
= xpalloc (print_buffer
, &print_buffer_size
, incr
, -1, 1);
264 memcpy (print_buffer
+ print_buffer_pos_byte
, ptr
, size_byte
);
265 print_buffer_pos
+= size
;
266 print_buffer_pos_byte
+= size_byte
;
268 else if (noninteractive
&& EQ (printcharfun
, Qt
))
270 fwrite (ptr
, 1, size_byte
, stdout
);
271 noninteractive_need_newline
= 1;
273 else if (EQ (printcharfun
, Qt
))
275 /* Output to echo area. We're trying to avoid a little overhead
276 here, that's the reason we don't call printchar to do the
280 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
282 setup_echo_area_for_printing (multibyte_p
);
283 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
285 if (size
== size_byte
)
287 for (i
= 0; i
< size
; ++i
)
288 insert_char ((unsigned char) *ptr
++);
293 for (i
= 0; i
< size_byte
; i
+= len
)
295 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
303 /* PRINTCHARFUN is a Lisp function. */
306 if (size
== size_byte
)
308 while (i
< size_byte
)
311 printchar (ch
, printcharfun
);
316 while (i
< size_byte
)
318 /* Here, we must convert each multi-byte form to the
319 corresponding character code before handing it to
322 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
324 printchar (ch
, printcharfun
);
331 /* Print the contents of a string STRING using PRINTCHARFUN.
332 It isn't safe to use strout in many cases,
333 because printing one char can relocate. */
336 print_string (Lisp_Object string
, Lisp_Object printcharfun
)
338 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
342 if (print_escape_nonascii
)
343 string
= string_escape_byte8 (string
);
345 if (STRING_MULTIBYTE (string
))
346 chars
= SCHARS (string
);
347 else if (! print_escape_nonascii
348 && (EQ (printcharfun
, Qt
)
349 ? ! NILP (BVAR (&buffer_defaults
, enable_multibyte_characters
))
350 : ! NILP (BVAR (current_buffer
, enable_multibyte_characters
))))
352 /* If unibyte string STRING contains 8-bit codes, we must
353 convert STRING to a multibyte string containing the same
358 chars
= SBYTES (string
);
359 bytes
= count_size_as_multibyte (SDATA (string
), chars
);
362 newstr
= make_uninit_multibyte_string (chars
, bytes
);
363 memcpy (SDATA (newstr
), SDATA (string
), chars
);
364 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
369 chars
= SBYTES (string
);
371 if (EQ (printcharfun
, Qt
))
373 /* Output to echo area. */
374 ptrdiff_t nbytes
= SBYTES (string
);
376 /* Copy the string contents so that relocation of STRING by
377 GC does not cause trouble. */
379 char *buffer
= SAFE_ALLOCA (nbytes
);
380 memcpy (buffer
, SDATA (string
), nbytes
);
382 strout (buffer
, chars
, nbytes
, printcharfun
);
387 /* No need to copy, since output to print_buffer can't GC. */
388 strout (SSDATA (string
), chars
, SBYTES (string
), printcharfun
);
392 /* Otherwise, string may be relocated by printing one char.
393 So re-fetch the string address for each character. */
395 ptrdiff_t size
= SCHARS (string
);
396 ptrdiff_t size_byte
= SBYTES (string
);
399 if (size
== size_byte
)
400 for (i
= 0; i
< size
; i
++)
401 printchar (SREF (string
, i
), printcharfun
);
403 for (i
= 0; i
< size_byte
; )
405 /* Here, we must convert each multi-byte form to the
406 corresponding character code before handing it to PRINTCHAR. */
408 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
, len
);
409 printchar (ch
, printcharfun
);
416 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
417 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
418 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
419 (Lisp_Object character
, Lisp_Object printcharfun
)
421 if (NILP (printcharfun
))
422 printcharfun
= Vstandard_output
;
423 CHECK_NUMBER (character
);
425 printchar (XINT (character
), printcharfun
);
430 /* Print the contents of a unibyte C string STRING using PRINTCHARFUN.
431 The caller should arrange to put this inside PRINTPREPARE and PRINTFINISH.
432 Do not use this on the contents of a Lisp string. */
435 print_c_string (char const *string
, Lisp_Object printcharfun
)
437 ptrdiff_t len
= strlen (string
);
438 strout (string
, len
, len
, printcharfun
);
441 /* Print unibyte C string at DATA on a specified stream PRINTCHARFUN.
442 Do not use this on the contents of a Lisp string. */
445 write_string_1 (const char *data
, Lisp_Object printcharfun
)
448 print_c_string (data
, printcharfun
);
452 /* Used from outside of print.c to print a C unibyte
453 string at DATA on the default output stream.
454 Do not use this on the contents of a Lisp string. */
457 write_string (const char *data
)
459 write_string_1 (data
, Vstandard_output
);
464 temp_output_buffer_setup (const char *bufname
)
466 ptrdiff_t count
= SPECPDL_INDEX ();
467 register struct buffer
*old
= current_buffer
;
468 register Lisp_Object buf
;
470 record_unwind_current_buffer ();
472 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
474 Fkill_all_local_variables ();
475 delete_all_overlays (current_buffer
);
476 bset_directory (current_buffer
, BVAR (old
, directory
));
477 bset_read_only (current_buffer
, Qnil
);
478 bset_filename (current_buffer
, Qnil
);
479 bset_undo_list (current_buffer
, Qt
);
480 eassert (current_buffer
->overlays_before
== NULL
);
481 eassert (current_buffer
->overlays_after
== NULL
);
482 bset_enable_multibyte_characters
483 (current_buffer
, BVAR (&buffer_defaults
, enable_multibyte_characters
));
484 specbind (Qinhibit_read_only
, Qt
);
485 specbind (Qinhibit_modification_hooks
, Qt
);
487 XSETBUFFER (buf
, current_buffer
);
489 run_hook (Qtemp_buffer_setup_hook
);
491 unbind_to (count
, Qnil
);
493 specbind (Qstandard_output
, buf
);
496 static void print (Lisp_Object
, Lisp_Object
, bool);
497 static void print_preprocess (Lisp_Object
);
498 static void print_preprocess_string (INTERVAL
, Lisp_Object
);
499 static void print_object (Lisp_Object
, Lisp_Object
, bool);
501 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 2, 0,
502 doc
: /* Output a newline to stream PRINTCHARFUN.
503 If ENSURE is non-nil only output a newline if not already at the
504 beginning of a line. Value is non-nil if a newline is printed.
505 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
506 (Lisp_Object printcharfun
, Lisp_Object ensure
)
510 if (NILP (printcharfun
))
511 printcharfun
= Vstandard_output
;
516 /* Difficult to check if at line beginning so abort. */
517 else if (FUNCTIONP (printcharfun
))
518 signal_error ("Unsupported function argument", printcharfun
);
519 else if (noninteractive
&& !NILP (printcharfun
))
520 val
= printchar_stdout_last
== 10 ? Qnil
: Qt
;
522 val
= NILP (Fbolp ()) ? Qt
: Qnil
;
525 printchar ('\n', printcharfun
);
530 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
531 doc
: /* Output the printed representation of OBJECT, any Lisp object.
532 Quoting characters are printed when needed to make output that `read'
533 can handle, whenever this is possible. For complex objects, the behavior
534 is controlled by `print-level' and `print-length', which see.
536 OBJECT is any of the Lisp data types: a number, a string, a symbol,
537 a list, a buffer, a window, a frame, etc.
539 A printed representation of an object is text which describes that object.
541 Optional argument PRINTCHARFUN is the output stream, which can be one
544 - a buffer, in which case output is inserted into that buffer at point;
545 - a marker, in which case output is inserted at marker's position;
546 - a function, in which case that function is called once for each
547 character of OBJECT's printed representation;
548 - a symbol, in which case that symbol's function definition is called; or
549 - t, in which case the output is displayed in the echo area.
551 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
553 (Lisp_Object object
, Lisp_Object printcharfun
)
555 if (NILP (printcharfun
))
556 printcharfun
= Vstandard_output
;
558 print (object
, printcharfun
, 1);
563 /* a buffer which is used to hold output being built by prin1-to-string */
564 Lisp_Object Vprin1_to_string_buffer
;
566 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
567 doc
: /* Return a string containing the printed representation of OBJECT.
568 OBJECT can be any Lisp object. This function outputs quoting characters
569 when necessary to make output that `read' can handle, whenever possible,
570 unless the optional second argument NOESCAPE is non-nil. For complex objects,
571 the behavior is controlled by `print-level' and `print-length', which see.
573 OBJECT is any of the Lisp data types: a number, a string, a symbol,
574 a list, a buffer, a window, a frame, etc.
576 A printed representation of an object is text which describes that object. */)
577 (Lisp_Object object
, Lisp_Object noescape
)
579 ptrdiff_t count
= SPECPDL_INDEX ();
581 specbind (Qinhibit_modification_hooks
, Qt
);
583 /* Save and restore this: we are altering a buffer
584 but we don't want to deactivate the mark just for that.
585 No need for specbind, since errors deactivate the mark. */
586 Lisp_Object save_deactivate_mark
= Vdeactivate_mark
;
587 bool prev_abort_on_gc
= abort_on_gc
;
590 Lisp_Object printcharfun
= Vprin1_to_string_buffer
;
592 print (object
, printcharfun
, NILP (noescape
));
593 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINISH */
596 struct buffer
*previous
= current_buffer
;
597 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
598 object
= Fbuffer_string ();
599 if (SBYTES (object
) == SCHARS (object
))
600 STRING_SET_UNIBYTE (object
);
602 /* Note that this won't make prepare_to_modify_buffer call
603 ask-user-about-supersession-threat because this buffer
604 does not visit a file. */
606 set_buffer_internal (previous
);
608 Vdeactivate_mark
= save_deactivate_mark
;
610 abort_on_gc
= prev_abort_on_gc
;
611 return unbind_to (count
, object
);
614 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
615 doc
: /* Output the printed representation of OBJECT, any Lisp object.
616 No quoting characters are used; no delimiters are printed around
617 the contents of strings.
619 OBJECT is any of the Lisp data types: a number, a string, a symbol,
620 a list, a buffer, a window, a frame, etc.
622 A printed representation of an object is text which describes that object.
624 Optional argument PRINTCHARFUN is the output stream, which can be one
627 - a buffer, in which case output is inserted into that buffer at point;
628 - a marker, in which case output is inserted at marker's position;
629 - a function, in which case that function is called once for each
630 character of OBJECT's printed representation;
631 - a symbol, in which case that symbol's function definition is called; or
632 - t, in which case the output is displayed in the echo area.
634 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
636 (Lisp_Object object
, Lisp_Object printcharfun
)
638 if (NILP (printcharfun
))
639 printcharfun
= Vstandard_output
;
641 print (object
, printcharfun
, 0);
646 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
647 doc
: /* Output the printed representation of OBJECT, with newlines around it.
648 Quoting characters are printed when needed to make output that `read'
649 can handle, whenever this is possible. For complex objects, the behavior
650 is controlled by `print-level' and `print-length', which see.
652 OBJECT is any of the Lisp data types: a number, a string, a symbol,
653 a list, a buffer, a window, a frame, etc.
655 A printed representation of an object is text which describes that object.
657 Optional argument PRINTCHARFUN is the output stream, which can be one
660 - a buffer, in which case output is inserted into that buffer at point;
661 - a marker, in which case output is inserted at marker's position;
662 - a function, in which case that function is called once for each
663 character of OBJECT's printed representation;
664 - a symbol, in which case that symbol's function definition is called; or
665 - t, in which case the output is displayed in the echo area.
667 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
669 (Lisp_Object object
, Lisp_Object printcharfun
)
673 if (NILP (printcharfun
))
674 printcharfun
= Vstandard_output
;
677 printchar ('\n', printcharfun
);
678 print (object
, printcharfun
, 1);
679 printchar ('\n', printcharfun
);
685 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
686 doc
: /* Write CHARACTER to stderr.
687 You can call print while debugging emacs, and pass it this function
688 to make it write to the debugging output. */)
689 (Lisp_Object character
)
693 CHECK_NUMBER (character
);
694 ch
= XINT (character
);
695 if (ASCII_CHAR_P (ch
))
699 /* Send the output to a debugger (nothing happens if there isn't
701 if (print_output_debug_flag
)
703 char buf
[2] = {(char) XINT (character
), '\0'};
704 OutputDebugString (buf
);
710 unsigned char mbstr
[MAX_MULTIBYTE_LENGTH
];
711 ptrdiff_t len
= CHAR_STRING (ch
, mbstr
);
712 Lisp_Object encoded_ch
=
713 ENCODE_SYSTEM (make_multibyte_string ((char *) mbstr
, 1, len
));
715 fwrite (SSDATA (encoded_ch
), SBYTES (encoded_ch
), 1, stderr
);
717 if (print_output_debug_flag
)
718 OutputDebugString (SSDATA (encoded_ch
));
725 /* This function is never called. Its purpose is to prevent
726 print_output_debug_flag from being optimized away. */
728 extern void debug_output_compilation_hack (bool) EXTERNALLY_VISIBLE
;
730 debug_output_compilation_hack (bool x
)
732 print_output_debug_flag
= x
;
735 #if defined (GNU_LINUX)
737 /* This functionality is not vitally important in general, so we rely on
738 non-portable ability to use stderr as lvalue. */
740 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
742 static FILE *initial_stderr_stream
= NULL
;
744 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
746 "FDebug output file: \nP",
747 doc
: /* Redirect debugging output (stderr stream) to file FILE.
748 If FILE is nil, reset target to the initial stderr stream.
749 Optional arg APPEND non-nil (interactively, with prefix arg) means
750 append to existing target file. */)
751 (Lisp_Object file
, Lisp_Object append
)
753 if (initial_stderr_stream
!= NULL
)
759 stderr
= initial_stderr_stream
;
760 initial_stderr_stream
= NULL
;
764 file
= Fexpand_file_name (file
, Qnil
);
765 initial_stderr_stream
= stderr
;
766 stderr
= emacs_fopen (SSDATA (file
), NILP (append
) ? "w" : "a");
769 stderr
= initial_stderr_stream
;
770 initial_stderr_stream
= NULL
;
771 report_file_error ("Cannot open debugging output stream", file
);
776 #endif /* GNU_LINUX */
779 /* This is the interface for debugging printing. */
782 debug_print (Lisp_Object arg
)
784 Fprin1 (arg
, Qexternal_debugging_output
);
785 fprintf (stderr
, "\r\n");
788 void safe_debug_print (Lisp_Object
) EXTERNALLY_VISIBLE
;
790 safe_debug_print (Lisp_Object arg
)
792 int valid
= valid_lisp_object_p (arg
);
797 fprintf (stderr
, "#<%s_LISP_OBJECT 0x%08"pI
"x>\r\n",
798 !valid
? "INVALID" : "SOME",
803 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
805 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
806 See Info anchor `(elisp)Definition of signal' for some details on how this
807 error message is constructed. */)
810 struct buffer
*old
= current_buffer
;
814 /* If OBJ is (error STRING), just return STRING.
815 That is not only faster, it also avoids the need to allocate
816 space here when the error is due to memory full. */
817 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
818 && CONSP (XCDR (obj
))
819 && STRINGP (XCAR (XCDR (obj
)))
820 && NILP (XCDR (XCDR (obj
))))
821 return XCAR (XCDR (obj
));
823 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
825 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
826 value
= Fbuffer_string ();
830 set_buffer_internal (old
);
836 /* Print an error message for the error DATA onto Lisp output stream
837 STREAM (suitable for the print functions).
838 CONTEXT is a C string describing the context of the error.
839 CALLER is the Lisp function inside which the error was signaled. */
842 print_error_message (Lisp_Object data
, Lisp_Object stream
, const char *context
,
845 Lisp_Object errname
, errmsg
, file_error
, tail
;
849 write_string_1 (context
, stream
);
851 /* If we know from where the error was signaled, show it in
853 if (!NILP (caller
) && SYMBOLP (caller
))
855 Lisp_Object cname
= SYMBOL_NAME (caller
);
856 ptrdiff_t cnamelen
= SBYTES (cname
);
858 char *name
= SAFE_ALLOCA (cnamelen
);
859 memcpy (name
, SDATA (cname
), cnamelen
);
860 message_dolog (name
, cnamelen
, 0, 0);
861 message_dolog (": ", 2, 0, 0);
865 errname
= Fcar (data
);
867 if (EQ (errname
, Qerror
))
872 errmsg
= Fcar (data
);
877 Lisp_Object error_conditions
= Fget (errname
, Qerror_conditions
);
878 errmsg
= Fget (errname
, Qerror_message
);
879 file_error
= Fmemq (Qfile_error
, error_conditions
);
882 /* Print an error message including the data items. */
884 tail
= Fcdr_safe (data
);
887 /* For file-error, make error message by concatenating
888 all the data items. They are all strings. */
889 if (!NILP (file_error
) && CONSP (tail
))
890 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
893 const char *sep
= ": ";
895 if (!STRINGP (errmsg
))
896 write_string_1 ("peculiar error", stream
);
897 else if (SCHARS (errmsg
))
898 Fprinc (errmsg
, stream
);
902 for (; CONSP (tail
); tail
= XCDR (tail
), sep
= ", ")
907 write_string_1 (sep
, stream
);
909 if (!NILP (file_error
)
910 || EQ (errname
, Qend_of_file
) || EQ (errname
, Quser_error
))
911 Fprinc (obj
, stream
);
913 Fprin1 (obj
, stream
);
923 * The buffer should be at least as large as the max string size of the
924 * largest float, printed in the biggest notation. This is undoubtedly
925 * 20d float_output_format, with the negative of the C-constant "HUGE"
928 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
930 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
931 * case of -1e307 in 20d float_output_format. What is one to do (short of
932 * re-writing _doprnt to be more sane)?
934 * Given the above, the buffer must be least FLOAT_TO_STRING_BUFSIZE bytes.
938 float_to_string (char *buf
, double data
)
944 /* Check for plus infinity in a way that won't lose
945 if there is no plus infinity. */
946 if (data
== data
/ 2 && data
> 1.0)
948 static char const infinity_string
[] = "1.0e+INF";
949 strcpy (buf
, infinity_string
);
950 return sizeof infinity_string
- 1;
952 /* Likewise for minus infinity. */
953 if (data
== data
/ 2 && data
< -1.0)
955 static char const minus_infinity_string
[] = "-1.0e+INF";
956 strcpy (buf
, minus_infinity_string
);
957 return sizeof minus_infinity_string
- 1;
959 /* Check for NaN in a way that won't fail if there are no NaNs. */
960 if (! (data
* 0.0 >= 0.0))
962 /* Prepend "-" if the NaN's sign bit is negative.
963 The sign bit of a double is the bit that is 1 in -0.0. */
964 static char const NaN_string
[] = "0.0e+NaN";
966 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
969 u_minus_zero
.d
= - 0.0;
970 for (i
= 0; i
< sizeof (double); i
++)
971 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
978 strcpy (buf
+ negative
, NaN_string
);
979 return negative
+ sizeof NaN_string
- 1;
982 if (NILP (Vfloat_output_format
)
983 || !STRINGP (Vfloat_output_format
))
986 /* Generate the fewest number of digits that represent the
987 floating point value without losing information. */
988 len
= dtoastr (buf
, FLOAT_TO_STRING_BUFSIZE
- 2, 0, 0, data
);
989 /* The decimal point must be printed, or the byte compiler can
990 get confused (Bug#8033). */
995 /* Check that the spec we have is fully valid.
996 This means not only valid for printf,
997 but meant for floats, and reasonable. */
998 cp
= SSDATA (Vfloat_output_format
);
1007 /* Check the width specification. */
1009 if ('0' <= *cp
&& *cp
<= '9')
1014 width
= (width
* 10) + (*cp
++ - '0');
1015 if (DBL_DIG
< width
)
1018 while (*cp
>= '0' && *cp
<= '9');
1020 /* A precision of zero is valid only for %f. */
1021 if (width
== 0 && *cp
!= 'f')
1025 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1031 len
= sprintf (buf
, SSDATA (Vfloat_output_format
), data
);
1034 /* Make sure there is a decimal point with digit after, or an
1035 exponent, so that the value is readable as a float. But don't do
1036 this with "%.0f"; it's valid for that not to produce a decimal
1037 point. Note that width can be 0 only for %.0f. */
1040 for (cp
= buf
; *cp
; cp
++)
1041 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1044 if (*cp
== '.' && cp
[1] == 0)
1064 print (Lisp_Object obj
, Lisp_Object printcharfun
, bool escapeflag
)
1066 new_backquote_output
= 0;
1068 /* Reset print_number_index and Vprint_number_table only when
1069 the variable Vprint_continuous_numbering is nil. Otherwise,
1070 the values of these variables will be kept between several
1072 if (NILP (Vprint_continuous_numbering
)
1073 || NILP (Vprint_number_table
))
1075 print_number_index
= 0;
1076 Vprint_number_table
= Qnil
;
1079 /* Construct Vprint_number_table for print-gensym and print-circle. */
1080 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1082 /* Construct Vprint_number_table.
1083 This increments print_number_index for the objects added. */
1085 print_preprocess (obj
);
1087 if (HASH_TABLE_P (Vprint_number_table
))
1088 { /* Remove unnecessary objects, which appear only once in OBJ;
1089 that is, whose status is Qt. */
1090 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vprint_number_table
);
1093 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
1094 if (!NILP (HASH_HASH (h
, i
))
1095 && EQ (HASH_VALUE (h
, i
), Qt
))
1096 Fremhash (HASH_KEY (h
, i
), Vprint_number_table
);
1101 print_object (obj
, printcharfun
, escapeflag
);
1104 #define PRINT_CIRCLE_CANDIDATE_P(obj) \
1105 (STRINGP (obj) || CONSP (obj) \
1106 || (VECTORLIKEP (obj) \
1107 && (VECTORP (obj) || COMPILEDP (obj) \
1108 || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \
1109 || HASH_TABLE_P (obj) || FONTP (obj))) \
1110 || (! NILP (Vprint_gensym) \
1112 && !SYMBOL_INTERNED_P (obj)))
1114 /* Construct Vprint_number_table according to the structure of OBJ.
1115 OBJ itself and all its elements will be added to Vprint_number_table
1116 recursively if it is a list, vector, compiled function, char-table,
1117 string (its text properties will be traced), or a symbol that has
1118 no obarray (this is for the print-gensym feature).
1119 The status fields of Vprint_number_table mean whether each object appears
1120 more than once in OBJ: Qnil at the first time, and Qt after that. */
1122 print_preprocess (Lisp_Object obj
)
1127 Lisp_Object halftail
;
1129 /* Avoid infinite recursion for circular nested structure
1130 in the case where Vprint_circle is nil. */
1131 if (NILP (Vprint_circle
))
1133 /* Give up if we go so deep that print_object will get an error. */
1134 /* See similar code in print_object. */
1135 if (print_depth
>= PRINT_CIRCLE
)
1136 error ("Apparently circular structure being printed");
1138 for (i
= 0; i
< print_depth
; i
++)
1139 if (EQ (obj
, being_printed
[i
]))
1141 being_printed
[print_depth
] = obj
;
1148 if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1150 if (!HASH_TABLE_P (Vprint_number_table
))
1151 Vprint_number_table
= CALLN (Fmake_hash_table
, QCtest
, Qeq
);
1153 /* In case print-circle is nil and print-gensym is t,
1154 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1155 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1157 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1159 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1160 always print the gensym with a number. This is a special for
1161 the lisp function byte-compile-output-docform. */
1162 || (!NILP (Vprint_continuous_numbering
)
1164 && !SYMBOL_INTERNED_P (obj
)))
1165 { /* OBJ appears more than once. Let's remember that. */
1166 if (!INTEGERP (num
))
1168 print_number_index
++;
1169 /* Negative number indicates it hasn't been printed yet. */
1170 Fputhash (obj
, make_number (- print_number_index
),
1171 Vprint_number_table
);
1177 /* OBJ is not yet recorded. Let's add to the table. */
1178 Fputhash (obj
, Qt
, Vprint_number_table
);
1181 switch (XTYPE (obj
))
1184 /* A string may have text properties, which can be circular. */
1185 traverse_intervals_noorder (string_intervals (obj
),
1186 print_preprocess_string
, Qnil
);
1190 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1191 just as in print_object. */
1192 if (loop_count
&& EQ (obj
, halftail
))
1194 print_preprocess (XCAR (obj
));
1197 if (!(loop_count
& 1))
1198 halftail
= XCDR (halftail
);
1201 case Lisp_Vectorlike
:
1203 if (size
& PSEUDOVECTOR_FLAG
)
1204 size
&= PSEUDOVECTOR_SIZE_MASK
;
1205 for (i
= (SUB_CHAR_TABLE_P (obj
)
1206 ? SUB_CHAR_TABLE_OFFSET
: 0); i
< size
; i
++)
1207 print_preprocess (AREF (obj
, i
));
1208 if (HASH_TABLE_P (obj
))
1209 { /* For hash tables, the key_and_value slot is past
1210 `size' because it needs to be marked specially in case
1211 the table is weak. */
1212 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1213 print_preprocess (h
->key_and_value
);
1225 print_preprocess_string (INTERVAL interval
, Lisp_Object arg
)
1227 print_preprocess (interval
->plist
);
1230 static void print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
);
1232 #define PRINT_STRING_NON_CHARSET_FOUND 1
1233 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1235 /* Bitwise or of the above macros. */
1236 static int print_check_string_result
;
1239 print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
)
1243 if (NILP (interval
->plist
)
1244 || (print_check_string_result
== (PRINT_STRING_NON_CHARSET_FOUND
1245 | PRINT_STRING_UNSAFE_CHARSET_FOUND
)))
1247 for (val
= interval
->plist
; CONSP (val
) && ! EQ (XCAR (val
), Qcharset
);
1248 val
= XCDR (XCDR (val
)));
1251 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1254 if (! (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
))
1256 if (! EQ (val
, interval
->plist
)
1257 || CONSP (XCDR (XCDR (val
))))
1258 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1260 if (NILP (Vprint_charset_text_property
)
1261 || ! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1264 ptrdiff_t charpos
= interval
->position
;
1265 ptrdiff_t bytepos
= string_char_to_byte (string
, charpos
);
1266 Lisp_Object charset
;
1268 charset
= XCAR (XCDR (val
));
1269 for (i
= 0; i
< LENGTH (interval
); i
++)
1271 FETCH_STRING_CHAR_ADVANCE (c
, string
, charpos
, bytepos
);
1272 if (! ASCII_CHAR_P (c
)
1273 && ! EQ (CHARSET_NAME (CHAR_CHARSET (c
)), charset
))
1275 print_check_string_result
|= PRINT_STRING_UNSAFE_CHARSET_FOUND
;
1282 /* The value is (charset . nil). */
1283 static Lisp_Object print_prune_charset_plist
;
1286 print_prune_string_charset (Lisp_Object string
)
1288 print_check_string_result
= 0;
1289 traverse_intervals (string_intervals (string
), 0,
1290 print_check_string_charset_prop
, string
);
1291 if (! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1293 string
= Fcopy_sequence (string
);
1294 if (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
)
1296 if (NILP (print_prune_charset_plist
))
1297 print_prune_charset_plist
= list1 (Qcharset
);
1298 Fremove_text_properties (make_number (0),
1299 make_number (SCHARS (string
)),
1300 print_prune_charset_plist
, string
);
1303 Fset_text_properties (make_number (0), make_number (SCHARS (string
)),
1310 print_object (Lisp_Object obj
, Lisp_Object printcharfun
, bool escapeflag
)
1312 char buf
[max (sizeof "from..to..in " + 2 * INT_STRLEN_BOUND (EMACS_INT
),
1313 max (sizeof " . #" + INT_STRLEN_BOUND (printmax_t
),
1318 /* Detect circularities and truncate them. */
1319 if (NILP (Vprint_circle
))
1321 /* Simple but incomplete way. */
1324 /* See similar code in print_preprocess. */
1325 if (print_depth
>= PRINT_CIRCLE
)
1326 error ("Apparently circular structure being printed");
1328 for (i
= 0; i
< print_depth
; i
++)
1329 if (EQ (obj
, being_printed
[i
]))
1331 int len
= sprintf (buf
, "#%d", i
);
1332 strout (buf
, len
, len
, printcharfun
);
1335 being_printed
[print_depth
] = obj
;
1337 else if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1339 /* With the print-circle feature. */
1340 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1343 EMACS_INT n
= XINT (num
);
1345 { /* Add a prefix #n= if OBJ has not yet been printed;
1346 that is, its status field is nil. */
1347 int len
= sprintf (buf
, "#%"pI
"d=", -n
);
1348 strout (buf
, len
, len
, printcharfun
);
1349 /* OBJ is going to be printed. Remember that fact. */
1350 Fputhash (obj
, make_number (- n
), Vprint_number_table
);
1354 /* Just print #n# if OBJ has already been printed. */
1355 int len
= sprintf (buf
, "#%"pI
"d#", n
);
1356 strout (buf
, len
, len
, printcharfun
);
1364 switch (XTYPE (obj
))
1368 int len
= sprintf (buf
, "%"pI
"d", XINT (obj
));
1369 strout (buf
, len
, len
, printcharfun
);
1375 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
1376 int len
= float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1377 strout (pigbuf
, len
, len
, printcharfun
);
1383 print_string (obj
, printcharfun
);
1386 register ptrdiff_t i
, i_byte
;
1387 struct gcpro gcpro1
;
1388 ptrdiff_t size_byte
;
1389 /* True means we must ensure that the next character we output
1390 cannot be taken as part of a hex character escape. */
1391 bool need_nonhex
= false;
1392 bool multibyte
= STRING_MULTIBYTE (obj
);
1396 if (! EQ (Vprint_charset_text_property
, Qt
))
1397 obj
= print_prune_string_charset (obj
);
1399 if (string_intervals (obj
))
1400 print_c_string ("#(", printcharfun
);
1402 printchar ('\"', printcharfun
);
1403 size_byte
= SBYTES (obj
);
1405 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1407 /* Here, we must convert each multi-byte form to the
1408 corresponding character code before handing it to printchar. */
1411 FETCH_STRING_CHAR_ADVANCE (c
, obj
, i
, i_byte
);
1416 ? (CHAR_BYTE8_P (c
) && (c
= CHAR_TO_BYTE8 (c
), true))
1417 : (SINGLE_BYTE_CHAR_P (c
) && ! ASCII_CHAR_P (c
)
1418 && print_escape_nonascii
))
1420 /* When printing a raw 8-bit byte in a multibyte buffer, or
1421 (when requested) a non-ASCII character in a unibyte buffer,
1422 print single-byte non-ASCII string chars
1423 using octal escapes. */
1425 int len
= sprintf (outbuf
, "\\%03o", c
);
1426 strout (outbuf
, len
, len
, printcharfun
);
1427 need_nonhex
= false;
1430 && ! ASCII_CHAR_P (c
) && print_escape_multibyte
)
1432 /* When requested, print multibyte chars using hex escapes. */
1433 char outbuf
[sizeof "\\x" + INT_STRLEN_BOUND (c
)];
1434 int len
= sprintf (outbuf
, "\\x%04x", c
);
1435 strout (outbuf
, len
, len
, printcharfun
);
1440 /* If we just had a hex escape, and this character
1441 could be taken as part of it,
1442 output `\ ' to prevent that. */
1443 if (need_nonhex
&& c_isxdigit (c
))
1444 print_c_string ("\\ ", printcharfun
);
1446 if (c
== '\n' && print_escape_newlines
1448 : c
== '\f' && print_escape_newlines
1450 : c
== '\"' || c
== '\\')
1451 printchar ('\\', printcharfun
);
1453 printchar (c
, printcharfun
);
1454 need_nonhex
= false;
1457 printchar ('\"', printcharfun
);
1459 if (string_intervals (obj
))
1461 traverse_intervals (string_intervals (obj
),
1462 0, print_interval
, printcharfun
);
1463 printchar (')', printcharfun
);
1473 unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1474 unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1476 ptrdiff_t i
, i_byte
;
1477 ptrdiff_t size_byte
;
1480 name
= SYMBOL_NAME (obj
);
1482 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1485 /* If symbol name begins with a digit, and ends with a digit,
1486 and contains nothing but digits and `e', it could be treated
1487 as a number. So set CONFUSING.
1489 Symbols that contain periods could also be taken as numbers,
1490 but periods are always escaped, so we don't have to worry
1492 else if (*p
>= '0' && *p
<= '9'
1493 && end
[-1] >= '0' && end
[-1] <= '9')
1495 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1496 /* Needed for \2e10. */
1497 || *p
== 'e' || *p
== 'E'))
1499 confusing
= (end
== p
);
1504 size_byte
= SBYTES (name
);
1506 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1507 print_c_string ("#:", printcharfun
);
1508 else if (size_byte
== 0)
1510 print_c_string ("##", printcharfun
);
1514 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1516 /* Here, we must convert each multi-byte form to the
1517 corresponding character code before handing it to PRINTCHAR. */
1518 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1523 if (c
== '\"' || c
== '\\' || c
== '\''
1524 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1525 || c
== ',' || c
== '.' || c
== '`'
1526 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1529 printchar ('\\', printcharfun
);
1533 printchar (c
, printcharfun
);
1539 /* If deeper than spec'd depth, print placeholder. */
1540 if (INTEGERP (Vprint_level
)
1541 && print_depth
> XINT (Vprint_level
))
1542 print_c_string ("...", printcharfun
);
1543 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1544 && (EQ (XCAR (obj
), Qquote
)))
1546 printchar ('\'', printcharfun
);
1547 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1549 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1550 && (EQ (XCAR (obj
), Qfunction
)))
1552 print_c_string ("#'", printcharfun
);
1553 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1555 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1556 && ((EQ (XCAR (obj
), Qbackquote
))))
1558 print_object (XCAR (obj
), printcharfun
, 0);
1559 new_backquote_output
++;
1560 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1561 new_backquote_output
--;
1563 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1564 && new_backquote_output
1565 && ((EQ (XCAR (obj
), Qbackquote
)
1566 || EQ (XCAR (obj
), Qcomma
)
1567 || EQ (XCAR (obj
), Qcomma_at
)
1568 || EQ (XCAR (obj
), Qcomma_dot
))))
1570 print_object (XCAR (obj
), printcharfun
, 0);
1571 new_backquote_output
--;
1572 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1573 new_backquote_output
++;
1577 printchar ('(', printcharfun
);
1579 Lisp_Object halftail
= obj
;
1581 /* Negative values of print-length are invalid in CL.
1582 Treat them like nil, as CMUCL does. */
1583 printmax_t print_length
= (NATNUMP (Vprint_length
)
1584 ? XFASTINT (Vprint_length
)
1585 : TYPE_MAXIMUM (printmax_t
));
1590 /* Detect circular list. */
1591 if (NILP (Vprint_circle
))
1593 /* Simple but incomplete way. */
1594 if (i
!= 0 && EQ (obj
, halftail
))
1596 int len
= sprintf (buf
, " . #%"pMd
, i
/ 2);
1597 strout (buf
, len
, len
, printcharfun
);
1603 /* With the print-circle feature. */
1606 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1609 print_c_string (" . ", printcharfun
);
1610 print_object (obj
, printcharfun
, escapeflag
);
1617 printchar (' ', printcharfun
);
1619 if (print_length
<= i
)
1621 print_c_string ("...", printcharfun
);
1626 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1630 halftail
= XCDR (halftail
);
1633 /* OBJ non-nil here means it's the end of a dotted list. */
1636 print_c_string (" . ", printcharfun
);
1637 print_object (obj
, printcharfun
, escapeflag
);
1641 printchar (')', printcharfun
);
1645 case Lisp_Vectorlike
:
1650 print_c_string ("#<process ", printcharfun
);
1651 print_string (XPROCESS (obj
)->name
, printcharfun
);
1652 printchar ('>', printcharfun
);
1655 print_string (XPROCESS (obj
)->name
, printcharfun
);
1657 else if (BOOL_VECTOR_P (obj
))
1661 struct gcpro gcpro1
;
1662 EMACS_INT size
= bool_vector_size (obj
);
1663 ptrdiff_t size_in_chars
= bool_vector_bytes (size
);
1664 ptrdiff_t real_size_in_chars
= size_in_chars
;
1667 int len
= sprintf (buf
, "#&%"pI
"d\"", size
);
1668 strout (buf
, len
, len
, printcharfun
);
1670 /* Don't print more characters than the specified maximum.
1671 Negative values of print-length are invalid. Treat them
1672 like a print-length of nil. */
1673 if (NATNUMP (Vprint_length
)
1674 && XFASTINT (Vprint_length
) < size_in_chars
)
1675 size_in_chars
= XFASTINT (Vprint_length
);
1677 for (i
= 0; i
< size_in_chars
; i
++)
1680 c
= bool_vector_uchar_data (obj
)[i
];
1681 if (c
== '\n' && print_escape_newlines
)
1682 print_c_string ("\\n", printcharfun
);
1683 else if (c
== '\f' && print_escape_newlines
)
1684 print_c_string ("\\f", printcharfun
);
1685 else if (c
> '\177')
1687 /* Use octal escapes to avoid encoding issues. */
1688 len
= sprintf (buf
, "\\%o", c
);
1689 strout (buf
, len
, len
, printcharfun
);
1693 if (c
== '\"' || c
== '\\')
1694 printchar ('\\', printcharfun
);
1695 printchar (c
, printcharfun
);
1699 if (size_in_chars
< real_size_in_chars
)
1700 print_c_string (" ...", printcharfun
);
1701 printchar ('\"', printcharfun
);
1705 else if (SUBRP (obj
))
1707 print_c_string ("#<subr ", printcharfun
);
1708 print_c_string (XSUBR (obj
)->symbol_name
, printcharfun
);
1709 printchar ('>', printcharfun
);
1711 else if (WINDOWP (obj
))
1713 int len
= sprintf (buf
, "#<window %"pI
"d",
1714 XWINDOW (obj
)->sequence_number
);
1715 strout (buf
, len
, len
, printcharfun
);
1716 if (BUFFERP (XWINDOW (obj
)->contents
))
1718 print_c_string (" on ", printcharfun
);
1719 print_string (BVAR (XBUFFER (XWINDOW (obj
)->contents
), name
),
1722 printchar ('>', printcharfun
);
1724 else if (TERMINALP (obj
))
1726 struct terminal
*t
= XTERMINAL (obj
);
1727 int len
= sprintf (buf
, "#<terminal %d", t
->id
);
1728 strout (buf
, len
, len
, printcharfun
);
1731 print_c_string (" on ", printcharfun
);
1732 print_c_string (t
->name
, printcharfun
);
1734 printchar ('>', printcharfun
);
1736 else if (HASH_TABLE_P (obj
))
1738 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1740 ptrdiff_t real_size
, size
;
1744 print_c_string ("#<hash-table", printcharfun
);
1745 if (SYMBOLP (h
->test
))
1747 print_c_string (" '", printcharfun
);
1748 print_c_string (SSDATA (SYMBOL_NAME (h
->test
)), printcharfun
);
1749 printchar (' ', printcharfun
);
1750 print_c_string (SSDATA (SYMBOL_NAME (h
->weak
)), printcharfun
);
1751 len
= sprintf (buf
, " %"pD
"d/%"pD
"d", h
->count
, ASIZE (h
->next
));
1752 strout (buf
, len
, len
, printcharfun
);
1754 len
= sprintf (buf
, " %p>", ptr
);
1755 strout (buf
, len
, len
, printcharfun
);
1757 /* Implement a readable output, e.g.:
1758 #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
1759 /* Always print the size. */
1760 len
= sprintf (buf
, "#s(hash-table size %"pD
"d", ASIZE (h
->next
));
1761 strout (buf
, len
, len
, printcharfun
);
1763 if (!NILP (h
->test
.name
))
1765 print_c_string (" test ", printcharfun
);
1766 print_object (h
->test
.name
, printcharfun
, escapeflag
);
1769 if (!NILP (h
->weak
))
1771 print_c_string (" weakness ", printcharfun
);
1772 print_object (h
->weak
, printcharfun
, escapeflag
);
1775 if (!NILP (h
->rehash_size
))
1777 print_c_string (" rehash-size ", printcharfun
);
1778 print_object (h
->rehash_size
, printcharfun
, escapeflag
);
1781 if (!NILP (h
->rehash_threshold
))
1783 print_c_string (" rehash-threshold ", printcharfun
);
1784 print_object (h
->rehash_threshold
, printcharfun
, escapeflag
);
1787 print_c_string (" data ", printcharfun
);
1789 /* Print the data here as a plist. */
1790 real_size
= HASH_TABLE_SIZE (h
);
1793 /* Don't print more elements than the specified maximum. */
1794 if (NATNUMP (Vprint_length
)
1795 && XFASTINT (Vprint_length
) < size
)
1796 size
= XFASTINT (Vprint_length
);
1798 printchar ('(', printcharfun
);
1799 for (i
= 0; i
< size
; i
++)
1800 if (!NILP (HASH_HASH (h
, i
)))
1802 if (i
) printchar (' ', printcharfun
);
1803 print_object (HASH_KEY (h
, i
), printcharfun
, escapeflag
);
1804 printchar (' ', printcharfun
);
1805 print_object (HASH_VALUE (h
, i
), printcharfun
, escapeflag
);
1808 if (size
< real_size
)
1809 print_c_string (" ...", printcharfun
);
1811 print_c_string ("))", printcharfun
);
1814 else if (BUFFERP (obj
))
1816 if (!BUFFER_LIVE_P (XBUFFER (obj
)))
1817 print_c_string ("#<killed buffer>", printcharfun
);
1818 else if (escapeflag
)
1820 print_c_string ("#<buffer ", printcharfun
);
1821 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1822 printchar ('>', printcharfun
);
1825 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1827 else if (WINDOW_CONFIGURATIONP (obj
))
1828 print_c_string ("#<window-configuration>", printcharfun
);
1829 else if (FRAMEP (obj
))
1832 void *ptr
= XFRAME (obj
);
1833 Lisp_Object frame_name
= XFRAME (obj
)->name
;
1835 print_c_string ((FRAME_LIVE_P (XFRAME (obj
))
1839 if (!STRINGP (frame_name
))
1841 /* A frame could be too young and have no name yet;
1843 if (SYMBOLP (frame_name
))
1844 frame_name
= Fsymbol_name (frame_name
);
1845 else /* can't happen: name should be either nil or string */
1846 frame_name
= build_string ("*INVALID*FRAME*NAME*");
1848 print_string (frame_name
, printcharfun
);
1849 len
= sprintf (buf
, " %p>", ptr
);
1850 strout (buf
, len
, len
, printcharfun
);
1852 else if (FONTP (obj
))
1856 if (! FONT_OBJECT_P (obj
))
1858 if (FONT_SPEC_P (obj
))
1859 print_c_string ("#<font-spec", printcharfun
);
1861 print_c_string ("#<font-entity", printcharfun
);
1862 for (i
= 0; i
< FONT_SPEC_MAX
; i
++)
1864 printchar (' ', printcharfun
);
1865 if (i
< FONT_WEIGHT_INDEX
|| i
> FONT_WIDTH_INDEX
)
1866 print_object (AREF (obj
, i
), printcharfun
, escapeflag
);
1868 print_object (font_style_symbolic (obj
, i
, 0),
1869 printcharfun
, escapeflag
);
1874 print_c_string ("#<font-object ", printcharfun
);
1875 print_object (AREF (obj
, FONT_NAME_INDEX
), printcharfun
,
1878 printchar ('>', printcharfun
);
1882 ptrdiff_t size
= ASIZE (obj
);
1883 if (COMPILEDP (obj
))
1885 printchar ('#', printcharfun
);
1886 size
&= PSEUDOVECTOR_SIZE_MASK
;
1888 if (CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
))
1890 /* We print a char-table as if it were a vector,
1891 lumping the parent and default slots in with the
1892 character slots. But we add #^ as a prefix. */
1894 /* Make each lowest sub_char_table start a new line.
1895 Otherwise we'll make a line extremely long, which
1896 results in slow redisplay. */
1897 if (SUB_CHAR_TABLE_P (obj
)
1898 && XSUB_CHAR_TABLE (obj
)->depth
== 3)
1899 printchar ('\n', printcharfun
);
1900 print_c_string ("#^", printcharfun
);
1901 if (SUB_CHAR_TABLE_P (obj
))
1902 printchar ('^', printcharfun
);
1903 size
&= PSEUDOVECTOR_SIZE_MASK
;
1905 if (size
& PSEUDOVECTOR_FLAG
)
1908 printchar ('[', printcharfun
);
1910 int i
, idx
= SUB_CHAR_TABLE_P (obj
) ? SUB_CHAR_TABLE_OFFSET
: 0;
1912 ptrdiff_t real_size
= size
;
1914 /* For a sub char-table, print heading non-Lisp data first. */
1915 if (SUB_CHAR_TABLE_P (obj
))
1917 i
= sprintf (buf
, "%d %d", XSUB_CHAR_TABLE (obj
)->depth
,
1918 XSUB_CHAR_TABLE (obj
)->min_char
);
1919 strout (buf
, i
, i
, printcharfun
);
1922 /* Don't print more elements than the specified maximum. */
1923 if (NATNUMP (Vprint_length
)
1924 && XFASTINT (Vprint_length
) < size
)
1925 size
= XFASTINT (Vprint_length
);
1927 for (i
= idx
; i
< size
; i
++)
1929 if (i
) printchar (' ', printcharfun
);
1930 tem
= AREF (obj
, i
);
1931 print_object (tem
, printcharfun
, escapeflag
);
1933 if (size
< real_size
)
1934 print_c_string (" ...", printcharfun
);
1936 printchar (']', printcharfun
);
1941 switch (XMISCTYPE (obj
))
1943 case Lisp_Misc_Marker
:
1944 print_c_string ("#<marker ", printcharfun
);
1945 /* Do you think this is necessary? */
1946 if (XMARKER (obj
)->insertion_type
!= 0)
1947 print_c_string ("(moves after insertion) ", printcharfun
);
1948 if (! XMARKER (obj
)->buffer
)
1949 print_c_string ("in no buffer", printcharfun
);
1952 int len
= sprintf (buf
, "at %"pD
"d in ", marker_position (obj
));
1953 strout (buf
, len
, len
, printcharfun
);
1954 print_string (BVAR (XMARKER (obj
)->buffer
, name
), printcharfun
);
1956 printchar ('>', printcharfun
);
1959 case Lisp_Misc_Overlay
:
1960 print_c_string ("#<overlay ", printcharfun
);
1961 if (! XMARKER (OVERLAY_START (obj
))->buffer
)
1962 print_c_string ("in no buffer", printcharfun
);
1965 int len
= sprintf (buf
, "from %"pD
"d to %"pD
"d in ",
1966 marker_position (OVERLAY_START (obj
)),
1967 marker_position (OVERLAY_END (obj
)));
1968 strout (buf
, len
, len
, printcharfun
);
1969 print_string (BVAR (XMARKER (OVERLAY_START (obj
))->buffer
, name
),
1972 printchar ('>', printcharfun
);
1975 case Lisp_Misc_Finalizer
:
1976 print_c_string ("#<finalizer", printcharfun
);
1977 if (NILP (XFINALIZER (obj
)->function
))
1978 print_c_string (" used", printcharfun
);
1979 printchar ('>', printcharfun
);
1982 /* Remaining cases shouldn't happen in normal usage, but let's
1983 print them anyway for the benefit of the debugger. */
1985 case Lisp_Misc_Free
:
1986 print_c_string ("#<misc free cell>", printcharfun
);
1989 case Lisp_Misc_Save_Value
:
1992 struct Lisp_Save_Value
*v
= XSAVE_VALUE (obj
);
1994 print_c_string ("#<save-value ", printcharfun
);
1996 if (v
->save_type
== SAVE_TYPE_MEMORY
)
1998 ptrdiff_t amount
= v
->data
[1].integer
;
2002 /* valid_lisp_object_p is reliable, so try to print up
2003 to 8 saved objects. This code is rarely used, so
2004 it's OK that valid_lisp_object_p is slow. */
2006 int limit
= min (amount
, 8);
2007 Lisp_Object
*area
= v
->data
[0].pointer
;
2009 i
= sprintf (buf
, "with %"pD
"d objects", amount
);
2010 strout (buf
, i
, i
, printcharfun
);
2012 for (i
= 0; i
< limit
; i
++)
2014 Lisp_Object maybe
= area
[i
];
2015 int valid
= valid_lisp_object_p (maybe
);
2017 printchar (' ', printcharfun
);
2019 print_object (maybe
, printcharfun
, escapeflag
);
2021 print_c_string (valid
< 0 ? "<some>" : "<invalid>",
2024 if (i
== limit
&& i
< amount
)
2025 print_c_string (" ...", printcharfun
);
2027 #else /* not GC_MARK_STACK */
2029 /* There is no reliable way to determine whether the objects
2030 are initialized, so do not try to print them. */
2032 i
= sprintf (buf
, "with %"pD
"d objects", amount
);
2033 strout (buf
, i
, i
, printcharfun
);
2035 #endif /* GC_MARK_STACK */
2039 /* Print each slot according to its type. */
2041 for (index
= 0; index
< SAVE_VALUE_SLOTS
; index
++)
2044 printchar (' ', printcharfun
);
2046 switch (save_type (v
, index
))
2049 i
= sprintf (buf
, "<unused>");
2053 i
= sprintf (buf
, "<pointer %p>",
2054 v
->data
[index
].pointer
);
2057 case SAVE_FUNCPOINTER
:
2058 i
= sprintf (buf
, "<funcpointer %p>",
2059 ((void *) (intptr_t)
2060 v
->data
[index
].funcpointer
));
2064 i
= sprintf (buf
, "<integer %"pD
"d>",
2065 v
->data
[index
].integer
);
2069 print_object (v
->data
[index
].object
, printcharfun
,
2077 strout (buf
, i
, i
, printcharfun
);
2080 printchar ('>', printcharfun
);
2093 /* We're in trouble if this happens!
2094 Probably should just emacs_abort (). */
2095 print_c_string ("#<EMACS BUG: INVALID DATATYPE ", printcharfun
);
2097 len
= sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2098 else if (VECTORLIKEP (obj
))
2099 len
= sprintf (buf
, "(PVEC 0x%08"pD
"x)", ASIZE (obj
));
2101 len
= sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2102 strout (buf
, len
, len
, printcharfun
);
2103 print_c_string ((" Save your buffers immediately"
2104 " and please report this bug>"),
2113 /* Print a description of INTERVAL using PRINTCHARFUN.
2114 This is part of printing a string that has text properties. */
2117 print_interval (INTERVAL interval
, Lisp_Object printcharfun
)
2119 if (NILP (interval
->plist
))
2121 printchar (' ', printcharfun
);
2122 print_object (make_number (interval
->position
), printcharfun
, 1);
2123 printchar (' ', printcharfun
);
2124 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2126 printchar (' ', printcharfun
);
2127 print_object (interval
->plist
, printcharfun
, 1);
2130 /* Initialize debug_print stuff early to have it working from the very
2134 init_print_once (void)
2136 /* The subroutine object for external-debugging-output is kept here
2137 for the convenience of the debugger. */
2138 DEFSYM (Qexternal_debugging_output
, "external-debugging-output");
2140 defsubr (&Sexternal_debugging_output
);
2144 syms_of_print (void)
2146 DEFSYM (Qtemp_buffer_setup_hook
, "temp-buffer-setup-hook");
2148 DEFVAR_LISP ("standard-output", Vstandard_output
,
2149 doc
: /* Output stream `print' uses by default for outputting a character.
2150 This may be any function of one argument.
2151 It may also be a buffer (output is inserted before point)
2152 or a marker (output is inserted and the marker is advanced)
2153 or the symbol t (output appears in the echo area). */);
2154 Vstandard_output
= Qt
;
2155 DEFSYM (Qstandard_output
, "standard-output");
2157 DEFVAR_LISP ("float-output-format", Vfloat_output_format
,
2158 doc
: /* The format descriptor string used to print floats.
2159 This is a %-spec like those accepted by `printf' in C,
2160 but with some restrictions. It must start with the two characters `%.'.
2161 After that comes an integer precision specification,
2162 and then a letter which controls the format.
2163 The letters allowed are `e', `f' and `g'.
2164 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2165 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2166 Use `g' to choose the shorter of those two formats for the number at hand.
2167 The precision in any of these cases is the number of digits following
2168 the decimal point. With `f', a precision of 0 means to omit the
2169 decimal point. 0 is not allowed with `e' or `g'.
2171 A value of nil means to use the shortest notation
2172 that represents the number without losing information. */);
2173 Vfloat_output_format
= Qnil
;
2174 DEFSYM (Qfloat_output_format
, "float-output-format");
2176 DEFVAR_LISP ("print-length", Vprint_length
,
2177 doc
: /* Maximum length of list to print before abbreviating.
2178 A value of nil means no limit. See also `eval-expression-print-length'. */);
2179 Vprint_length
= Qnil
;
2181 DEFVAR_LISP ("print-level", Vprint_level
,
2182 doc
: /* Maximum depth of list nesting to print before abbreviating.
2183 A value of nil means no limit. See also `eval-expression-print-level'. */);
2184 Vprint_level
= Qnil
;
2186 DEFVAR_BOOL ("print-escape-newlines", print_escape_newlines
,
2187 doc
: /* Non-nil means print newlines in strings as `\\n'.
2188 Also print formfeeds as `\\f'. */);
2189 print_escape_newlines
= 0;
2191 DEFVAR_BOOL ("print-escape-nonascii", print_escape_nonascii
,
2192 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2193 \(OOO is the octal representation of the character code.)
2194 Only single-byte characters are affected, and only in `prin1'.
2195 When the output goes in a multibyte buffer, this feature is
2196 enabled regardless of the value of the variable. */);
2197 print_escape_nonascii
= 0;
2199 DEFVAR_BOOL ("print-escape-multibyte", print_escape_multibyte
,
2200 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2201 \(XXXX is the hex representation of the character code.)
2202 This affects only `prin1'. */);
2203 print_escape_multibyte
= 0;
2205 DEFVAR_BOOL ("print-quoted", print_quoted
,
2206 doc
: /* Non-nil means print quoted forms with reader syntax.
2207 I.e., (quote foo) prints as 'foo, (function foo) as #'foo. */);
2210 DEFVAR_LISP ("print-gensym", Vprint_gensym
,
2211 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2212 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2213 When the uninterned symbol appears within a recursive data structure,
2214 and the symbol appears more than once, in addition use the #N# and #N=
2215 constructs as needed, so that multiple references to the same symbol are
2216 shared once again when the text is read back. */);
2217 Vprint_gensym
= Qnil
;
2219 DEFVAR_LISP ("print-circle", Vprint_circle
,
2220 doc
: /* Non-nil means print recursive structures using #N= and #N# syntax.
2221 If nil, printing proceeds recursively and may lead to
2222 `max-lisp-eval-depth' being exceeded or an error may occur:
2223 \"Apparently circular structure being printed.\" Also see
2224 `print-length' and `print-level'.
2225 If non-nil, shared substructures anywhere in the structure are printed
2226 with `#N=' before the first occurrence (in the order of the print
2227 representation) and `#N#' in place of each subsequent occurrence,
2228 where N is a positive decimal integer. */);
2229 Vprint_circle
= Qnil
;
2231 DEFVAR_LISP ("print-continuous-numbering", Vprint_continuous_numbering
,
2232 doc
: /* Non-nil means number continuously across print calls.
2233 This affects the numbers printed for #N= labels and #M# references.
2234 See also `print-circle', `print-gensym', and `print-number-table'.
2235 This variable should not be set with `setq'; bind it with a `let' instead. */);
2236 Vprint_continuous_numbering
= Qnil
;
2238 DEFVAR_LISP ("print-number-table", Vprint_number_table
,
2239 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2240 The Lisp printer uses this vector to detect Lisp objects referenced more
2243 When you bind `print-continuous-numbering' to t, you should probably
2244 also bind `print-number-table' to nil. This ensures that the value of
2245 `print-number-table' can be garbage-collected once the printing is
2246 done. If all elements of `print-number-table' are nil, it means that
2247 the printing done so far has not found any shared structure or objects
2248 that need to be recorded in the table. */);
2249 Vprint_number_table
= Qnil
;
2251 DEFVAR_LISP ("print-charset-text-property", Vprint_charset_text_property
,
2252 doc
: /* A flag to control printing of `charset' text property on printing a string.
2253 The value must be nil, t, or `default'.
2255 If the value is nil, don't print the text property `charset'.
2257 If the value is t, always print the text property `charset'.
2259 If the value is `default', print the text property `charset' only when
2260 the value is different from what is guessed in the current charset
2262 Vprint_charset_text_property
= Qdefault
;
2264 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2265 staticpro (&Vprin1_to_string_buffer
);
2268 defsubr (&Sprin1_to_string
);
2269 defsubr (&Serror_message_string
);
2273 defsubr (&Swrite_char
);
2274 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2275 defsubr (&Sredirect_debugging_output
);
2278 DEFSYM (Qprint_escape_newlines
, "print-escape-newlines");
2279 DEFSYM (Qprint_escape_multibyte
, "print-escape-multibyte");
2280 DEFSYM (Qprint_escape_nonascii
, "print-escape-nonascii");
2282 print_prune_charset_plist
= Qnil
;
2283 staticpro (&print_prune_charset_plist
);