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. */
47 /* Avoid actual stack overflow in print. */
48 static ptrdiff_t print_depth
;
50 /* Level of nesting inside outputting backquote in new style. */
51 static ptrdiff_t new_backquote_output
;
53 /* Detect most circularities to print finite output. */
54 #define PRINT_CIRCLE 200
55 static Lisp_Object being_printed
[PRINT_CIRCLE
];
57 /* Last char printed to stdout by printchar. */
58 static unsigned int printchar_stdout_last
;
60 /* When printing into a buffer, first we put the text in this
61 block, then insert it all at once. */
62 static char *print_buffer
;
64 /* Size allocated in print_buffer. */
65 static ptrdiff_t print_buffer_size
;
66 /* Chars stored in print_buffer. */
67 static ptrdiff_t print_buffer_pos
;
68 /* Bytes stored in print_buffer. */
69 static ptrdiff_t print_buffer_pos_byte
;
71 /* Vprint_number_table is a table, that keeps objects that are going to
72 be printed, to allow use of #n= and #n# to express sharing.
73 For any given object, the table can give the following values:
74 t the object will be printed only once.
75 -N the object will be printed several times and will take number N.
76 N the object has been printed so we can refer to it as #N#.
77 print_number_index holds the largest N already used.
78 N has to be striclty larger than 0 since we need to distinguish -N. */
79 static ptrdiff_t print_number_index
;
80 static void print_interval (INTERVAL interval
, Lisp_Object printcharfun
);
82 /* GDB resets this to zero on W32 to disable OutputDebugString calls. */
83 bool print_output_debug_flag EXTERNALLY_VISIBLE
= 1;
86 /* Low level output routines for characters and strings. */
88 /* Lisp functions to do output using a stream
89 must have the stream in a variable called printcharfun
90 and must start with PRINTPREPARE, end with PRINTFINISH,
91 and use PRINTDECLARE to declare common variables.
92 Use PRINTCHAR to output one character,
93 or call strout to output a block of characters. */
95 #define PRINTDECLARE \
96 struct buffer *old = current_buffer; \
97 ptrdiff_t old_point = -1, start_point = -1; \
98 ptrdiff_t old_point_byte = -1, start_point_byte = -1; \
99 ptrdiff_t specpdl_count = SPECPDL_INDEX (); \
100 bool free_print_buffer = 0; \
102 = !NILP (BVAR (current_buffer, enable_multibyte_characters)); \
105 #define PRINTPREPARE \
106 original = printcharfun; \
107 if (NILP (printcharfun)) printcharfun = Qt; \
108 if (BUFFERP (printcharfun)) \
110 if (XBUFFER (printcharfun) != current_buffer) \
111 Fset_buffer (printcharfun); \
112 printcharfun = Qnil; \
114 if (MARKERP (printcharfun)) \
116 ptrdiff_t marker_pos; \
117 if (! XMARKER (printcharfun)->buffer) \
118 error ("Marker does not point anywhere"); \
119 if (XMARKER (printcharfun)->buffer != current_buffer) \
120 set_buffer_internal (XMARKER (printcharfun)->buffer); \
121 marker_pos = marker_position (printcharfun); \
122 if (marker_pos < BEGV || marker_pos > ZV) \
123 signal_error ("Marker is outside the accessible " \
124 "part of the buffer", printcharfun); \
126 old_point_byte = PT_BYTE; \
127 SET_PT_BOTH (marker_pos, \
128 marker_byte_position (printcharfun)); \
130 start_point_byte = PT_BYTE; \
131 printcharfun = Qnil; \
133 if (NILP (printcharfun)) \
135 Lisp_Object string; \
136 if (NILP (BVAR (current_buffer, enable_multibyte_characters)) \
137 && ! print_escape_multibyte) \
138 specbind (Qprint_escape_multibyte, Qt); \
139 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)) \
140 && ! print_escape_nonascii) \
141 specbind (Qprint_escape_nonascii, Qt); \
142 if (print_buffer != 0) \
144 string = make_string_from_bytes (print_buffer, \
146 print_buffer_pos_byte); \
147 record_unwind_protect (print_unwind, string); \
151 int new_size = 1000; \
152 print_buffer = xmalloc (new_size); \
153 print_buffer_size = new_size; \
154 free_print_buffer = 1; \
156 print_buffer_pos = 0; \
157 print_buffer_pos_byte = 0; \
159 if (EQ (printcharfun, Qt) && ! noninteractive) \
160 setup_echo_area_for_printing (multibyte);
162 #define PRINTFINISH \
163 if (NILP (printcharfun)) \
165 if (print_buffer_pos != print_buffer_pos_byte \
166 && NILP (BVAR (current_buffer, enable_multibyte_characters)))\
169 unsigned char *temp = SAFE_ALLOCA (print_buffer_pos + 1); \
170 copy_text ((unsigned char *) print_buffer, temp, \
171 print_buffer_pos_byte, 1, 0); \
172 insert_1_both ((char *) temp, print_buffer_pos, \
173 print_buffer_pos, 0, 1, 0); \
177 insert_1_both (print_buffer, print_buffer_pos, \
178 print_buffer_pos_byte, 0, 1, 0); \
179 signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
181 if (free_print_buffer) \
183 xfree (print_buffer); \
186 unbind_to (specpdl_count, Qnil); \
187 if (MARKERP (original)) \
188 set_marker_both (original, Qnil, PT, PT_BYTE); \
189 if (old_point >= 0) \
190 SET_PT_BOTH (old_point + (old_point >= start_point \
191 ? PT - start_point : 0), \
192 old_point_byte + (old_point_byte >= start_point_byte \
193 ? PT_BYTE - start_point_byte : 0)); \
194 set_buffer_internal (old);
196 #define PRINTCHAR(ch) printchar (ch, printcharfun)
198 /* This is used to restore the saved contents of print_buffer
199 when there is a recursive call to print. */
202 print_unwind (Lisp_Object saved_text
)
204 memcpy (print_buffer
, SDATA (saved_text
), SCHARS (saved_text
));
208 /* Print character CH using method FUN. FUN nil means print to
209 print_buffer. FUN t means print to echo area or stdout if
210 non-interactive. If FUN is neither nil nor t, call FUN with CH as
214 printchar (unsigned int ch
, Lisp_Object fun
)
216 if (!NILP (fun
) && !EQ (fun
, Qt
))
217 call1 (fun
, make_number (ch
));
220 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
221 int len
= CHAR_STRING (ch
, str
);
227 ptrdiff_t incr
= len
- (print_buffer_size
- print_buffer_pos_byte
);
229 print_buffer
= xpalloc (print_buffer
, &print_buffer_size
,
231 memcpy (print_buffer
+ print_buffer_pos_byte
, str
, len
);
232 print_buffer_pos
+= 1;
233 print_buffer_pos_byte
+= len
;
235 else if (noninteractive
)
237 printchar_stdout_last
= ch
;
238 fwrite (str
, 1, len
, stdout
);
239 noninteractive_need_newline
= 1;
244 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
246 setup_echo_area_for_printing (multibyte_p
);
248 message_dolog ((char *) str
, len
, 0, multibyte_p
);
254 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
255 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
256 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
257 print_buffer. PRINTCHARFUN t means output to the echo area or to
258 stdout if non-interactive. If neither nil nor t, call Lisp
259 function PRINTCHARFUN for each character printed. MULTIBYTE
260 non-zero means PTR contains multibyte characters.
262 In the case where PRINTCHARFUN is nil, it is safe for PTR to point
263 to data in a Lisp string. Otherwise that is not safe. */
266 strout (const char *ptr
, ptrdiff_t size
, ptrdiff_t size_byte
,
267 Lisp_Object printcharfun
)
270 size_byte
= size
= strlen (ptr
);
272 if (NILP (printcharfun
))
274 ptrdiff_t incr
= size_byte
- (print_buffer_size
- print_buffer_pos_byte
);
276 print_buffer
= xpalloc (print_buffer
, &print_buffer_size
, incr
, -1, 1);
277 memcpy (print_buffer
+ print_buffer_pos_byte
, ptr
, size_byte
);
278 print_buffer_pos
+= size
;
279 print_buffer_pos_byte
+= size_byte
;
281 else if (noninteractive
&& EQ (printcharfun
, Qt
))
283 fwrite (ptr
, 1, size_byte
, stdout
);
284 noninteractive_need_newline
= 1;
286 else if (EQ (printcharfun
, Qt
))
288 /* Output to echo area. We're trying to avoid a little overhead
289 here, that's the reason we don't call printchar to do the
293 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
295 setup_echo_area_for_printing (multibyte_p
);
296 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
298 if (size
== size_byte
)
300 for (i
= 0; i
< size
; ++i
)
301 insert_char ((unsigned char) *ptr
++);
306 for (i
= 0; i
< size_byte
; i
+= len
)
308 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
316 /* PRINTCHARFUN is a Lisp function. */
319 if (size
== size_byte
)
321 while (i
< size_byte
)
329 while (i
< size_byte
)
331 /* Here, we must convert each multi-byte form to the
332 corresponding character code before handing it to
335 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
344 /* Print the contents of a string STRING using PRINTCHARFUN.
345 It isn't safe to use strout in many cases,
346 because printing one char can relocate. */
349 print_string (Lisp_Object string
, Lisp_Object printcharfun
)
351 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
355 if (print_escape_nonascii
)
356 string
= string_escape_byte8 (string
);
358 if (STRING_MULTIBYTE (string
))
359 chars
= SCHARS (string
);
360 else if (! print_escape_nonascii
361 && (EQ (printcharfun
, Qt
)
362 ? ! NILP (BVAR (&buffer_defaults
, enable_multibyte_characters
))
363 : ! NILP (BVAR (current_buffer
, enable_multibyte_characters
))))
365 /* If unibyte string STRING contains 8-bit codes, we must
366 convert STRING to a multibyte string containing the same
371 chars
= SBYTES (string
);
372 bytes
= count_size_as_multibyte (SDATA (string
), chars
);
375 newstr
= make_uninit_multibyte_string (chars
, bytes
);
376 memcpy (SDATA (newstr
), SDATA (string
), chars
);
377 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
382 chars
= SBYTES (string
);
384 if (EQ (printcharfun
, Qt
))
386 /* Output to echo area. */
387 ptrdiff_t nbytes
= SBYTES (string
);
389 /* Copy the string contents so that relocation of STRING by
390 GC does not cause trouble. */
392 char *buffer
= SAFE_ALLOCA (nbytes
);
393 memcpy (buffer
, SDATA (string
), nbytes
);
395 strout (buffer
, chars
, nbytes
, printcharfun
);
400 /* No need to copy, since output to print_buffer can't GC. */
401 strout (SSDATA (string
), chars
, SBYTES (string
), printcharfun
);
405 /* Otherwise, string may be relocated by printing one char.
406 So re-fetch the string address for each character. */
408 ptrdiff_t size
= SCHARS (string
);
409 ptrdiff_t size_byte
= SBYTES (string
);
412 if (size
== size_byte
)
413 for (i
= 0; i
< size
; i
++)
414 PRINTCHAR (SREF (string
, i
));
416 for (i
= 0; i
< size_byte
; )
418 /* Here, we must convert each multi-byte form to the
419 corresponding character code before handing it to PRINTCHAR. */
421 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
, len
);
429 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
430 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
431 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
432 (Lisp_Object character
, Lisp_Object printcharfun
)
436 if (NILP (printcharfun
))
437 printcharfun
= Vstandard_output
;
438 CHECK_NUMBER (character
);
440 PRINTCHAR (XINT (character
));
445 /* Used from outside of print.c to print a block of SIZE
446 single-byte chars at DATA on the default output stream.
447 Do not use this on the contents of a Lisp string. */
450 write_string (const char *data
, int size
)
453 Lisp_Object printcharfun
;
455 printcharfun
= Vstandard_output
;
458 strout (data
, size
, size
, printcharfun
);
462 /* Used to print a block of SIZE single-byte chars at DATA on a
463 specified stream PRINTCHARFUN.
464 Do not use this on the contents of a Lisp string. */
467 write_string_1 (const char *data
, int size
, Lisp_Object printcharfun
)
472 strout (data
, size
, size
, printcharfun
);
478 temp_output_buffer_setup (const char *bufname
)
480 ptrdiff_t count
= SPECPDL_INDEX ();
481 register struct buffer
*old
= current_buffer
;
482 register Lisp_Object buf
;
484 record_unwind_current_buffer ();
486 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
488 Fkill_all_local_variables ();
489 delete_all_overlays (current_buffer
);
490 bset_directory (current_buffer
, BVAR (old
, directory
));
491 bset_read_only (current_buffer
, Qnil
);
492 bset_filename (current_buffer
, Qnil
);
493 bset_undo_list (current_buffer
, Qt
);
494 eassert (current_buffer
->overlays_before
== NULL
);
495 eassert (current_buffer
->overlays_after
== NULL
);
496 bset_enable_multibyte_characters
497 (current_buffer
, BVAR (&buffer_defaults
, enable_multibyte_characters
));
498 specbind (Qinhibit_read_only
, Qt
);
499 specbind (Qinhibit_modification_hooks
, Qt
);
501 XSETBUFFER (buf
, current_buffer
);
503 run_hook (Qtemp_buffer_setup_hook
);
505 unbind_to (count
, Qnil
);
507 specbind (Qstandard_output
, buf
);
510 static void print (Lisp_Object
, Lisp_Object
, bool);
511 static void print_preprocess (Lisp_Object
);
512 static void print_preprocess_string (INTERVAL
, Lisp_Object
);
513 static void print_object (Lisp_Object
, Lisp_Object
, bool);
515 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 2, 0,
516 doc
: /* Output a newline to stream PRINTCHARFUN.
517 If ENSURE is non-nil only output a newline if not already at the
518 beginning of a line. Value is non-nil if a newline is printed.
519 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
520 (Lisp_Object printcharfun
, Lisp_Object ensure
)
522 Lisp_Object val
= Qnil
;
525 if (NILP (printcharfun
))
526 printcharfun
= Vstandard_output
;
531 /* Difficult to check if at line beginning so abort. */
532 else if (FUNCTIONP (printcharfun
))
533 signal_error ("Unsupported function argument", printcharfun
);
534 else if (noninteractive
&& !NILP (printcharfun
))
535 val
= printchar_stdout_last
== 10 ? Qnil
: Qt
;
536 else if (NILP (Fbolp ()))
539 if (!NILP (val
)) PRINTCHAR ('\n');
544 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
545 doc
: /* Output the printed representation of OBJECT, any Lisp object.
546 Quoting characters are printed when needed to make output that `read'
547 can handle, whenever this is possible. For complex objects, the behavior
548 is controlled by `print-level' and `print-length', which see.
550 OBJECT is any of the Lisp data types: a number, a string, a symbol,
551 a list, a buffer, a window, a frame, etc.
553 A printed representation of an object is text which describes that object.
555 Optional argument PRINTCHARFUN is the output stream, which can be one
558 - a buffer, in which case output is inserted into that buffer at point;
559 - a marker, in which case output is inserted at marker's position;
560 - a function, in which case that function is called once for each
561 character of OBJECT's printed representation;
562 - a symbol, in which case that symbol's function definition is called; or
563 - t, in which case the output is displayed in the echo area.
565 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
567 (Lisp_Object object
, Lisp_Object printcharfun
)
571 if (NILP (printcharfun
))
572 printcharfun
= Vstandard_output
;
574 print (object
, printcharfun
, 1);
579 /* a buffer which is used to hold output being built by prin1-to-string */
580 Lisp_Object Vprin1_to_string_buffer
;
582 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
583 doc
: /* Return a string containing the printed representation of OBJECT.
584 OBJECT can be any Lisp object. This function outputs quoting characters
585 when necessary to make output that `read' can handle, whenever possible,
586 unless the optional second argument NOESCAPE is non-nil. For complex objects,
587 the behavior is controlled by `print-level' and `print-length', which see.
589 OBJECT is any of the Lisp data types: a number, a string, a symbol,
590 a list, a buffer, a window, a frame, etc.
592 A printed representation of an object is text which describes that object. */)
593 (Lisp_Object object
, Lisp_Object noescape
)
595 Lisp_Object printcharfun
;
596 bool prev_abort_on_gc
;
597 Lisp_Object save_deactivate_mark
;
598 ptrdiff_t count
= SPECPDL_INDEX ();
599 struct buffer
*previous
;
601 specbind (Qinhibit_modification_hooks
, Qt
);
606 /* Save and restore this--we are altering a buffer
607 but we don't want to deactivate the mark just for that.
608 No need for specbind, since errors deactivate the mark. */
609 save_deactivate_mark
= Vdeactivate_mark
;
610 prev_abort_on_gc
= abort_on_gc
;
613 printcharfun
= Vprin1_to_string_buffer
;
615 print (object
, printcharfun
, NILP (noescape
));
616 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINISH */
620 previous
= current_buffer
;
621 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
622 object
= Fbuffer_string ();
623 if (SBYTES (object
) == SCHARS (object
))
624 STRING_SET_UNIBYTE (object
);
626 /* Note that this won't make prepare_to_modify_buffer call
627 ask-user-about-supersession-threat because this buffer
628 does not visit a file. */
630 set_buffer_internal (previous
);
632 Vdeactivate_mark
= save_deactivate_mark
;
634 abort_on_gc
= prev_abort_on_gc
;
635 return unbind_to (count
, object
);
638 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
639 doc
: /* Output the printed representation of OBJECT, any Lisp object.
640 No quoting characters are used; no delimiters are printed around
641 the contents of strings.
643 OBJECT is any of the Lisp data types: a number, a string, a symbol,
644 a list, a buffer, a window, a frame, etc.
646 A printed representation of an object is text which describes that object.
648 Optional argument PRINTCHARFUN is the output stream, which can be one
651 - a buffer, in which case output is inserted into that buffer at point;
652 - a marker, in which case output is inserted at marker's position;
653 - a function, in which case that function is called once for each
654 character of OBJECT's printed representation;
655 - a symbol, in which case that symbol's function definition is called; or
656 - t, in which case the output is displayed in the echo area.
658 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
660 (Lisp_Object object
, Lisp_Object printcharfun
)
664 if (NILP (printcharfun
))
665 printcharfun
= Vstandard_output
;
667 print (object
, printcharfun
, 0);
672 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
673 doc
: /* Output the printed representation of OBJECT, with newlines around it.
674 Quoting characters are printed when needed to make output that `read'
675 can handle, whenever this is possible. For complex objects, the behavior
676 is controlled by `print-level' and `print-length', which see.
678 OBJECT is any of the Lisp data types: a number, a string, a symbol,
679 a list, a buffer, a window, a frame, etc.
681 A printed representation of an object is text which describes that object.
683 Optional argument PRINTCHARFUN is the output stream, which can be one
686 - a buffer, in which case output is inserted into that buffer at point;
687 - a marker, in which case output is inserted at marker's position;
688 - a function, in which case that function is called once for each
689 character of OBJECT's printed representation;
690 - a symbol, in which case that symbol's function definition is called; or
691 - t, in which case the output is displayed in the echo area.
693 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
695 (Lisp_Object object
, Lisp_Object printcharfun
)
700 if (NILP (printcharfun
))
701 printcharfun
= Vstandard_output
;
705 print (object
, printcharfun
, 1);
712 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
713 doc
: /* Write CHARACTER to stderr.
714 You can call print while debugging emacs, and pass it this function
715 to make it write to the debugging output. */)
716 (Lisp_Object character
)
720 CHECK_NUMBER (character
);
721 ch
= XINT (character
);
722 if (ASCII_CHAR_P (ch
))
726 /* Send the output to a debugger (nothing happens if there isn't
728 if (print_output_debug_flag
)
730 char buf
[2] = {(char) XINT (character
), '\0'};
731 OutputDebugString (buf
);
737 unsigned char mbstr
[MAX_MULTIBYTE_LENGTH
];
738 ptrdiff_t len
= CHAR_STRING (ch
, mbstr
);
739 Lisp_Object encoded_ch
=
740 ENCODE_SYSTEM (make_multibyte_string ((char *) mbstr
, 1, len
));
742 fwrite (SSDATA (encoded_ch
), SBYTES (encoded_ch
), 1, stderr
);
744 if (print_output_debug_flag
)
745 OutputDebugString (SSDATA (encoded_ch
));
752 /* This function is never called. Its purpose is to prevent
753 print_output_debug_flag from being optimized away. */
755 extern void debug_output_compilation_hack (bool) EXTERNALLY_VISIBLE
;
757 debug_output_compilation_hack (bool x
)
759 print_output_debug_flag
= x
;
762 #if defined (GNU_LINUX)
764 /* This functionality is not vitally important in general, so we rely on
765 non-portable ability to use stderr as lvalue. */
767 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
769 static FILE *initial_stderr_stream
= NULL
;
771 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
773 "FDebug output file: \nP",
774 doc
: /* Redirect debugging output (stderr stream) to file FILE.
775 If FILE is nil, reset target to the initial stderr stream.
776 Optional arg APPEND non-nil (interactively, with prefix arg) means
777 append to existing target file. */)
778 (Lisp_Object file
, Lisp_Object append
)
780 if (initial_stderr_stream
!= NULL
)
786 stderr
= initial_stderr_stream
;
787 initial_stderr_stream
= NULL
;
791 file
= Fexpand_file_name (file
, Qnil
);
792 initial_stderr_stream
= stderr
;
793 stderr
= emacs_fopen (SSDATA (file
), NILP (append
) ? "w" : "a");
796 stderr
= initial_stderr_stream
;
797 initial_stderr_stream
= NULL
;
798 report_file_error ("Cannot open debugging output stream", file
);
803 #endif /* GNU_LINUX */
806 /* This is the interface for debugging printing. */
809 debug_print (Lisp_Object arg
)
811 Fprin1 (arg
, Qexternal_debugging_output
);
812 fprintf (stderr
, "\r\n");
815 void safe_debug_print (Lisp_Object
) EXTERNALLY_VISIBLE
;
817 safe_debug_print (Lisp_Object arg
)
819 int valid
= valid_lisp_object_p (arg
);
824 fprintf (stderr
, "#<%s_LISP_OBJECT 0x%08"pI
"x>\r\n",
825 !valid
? "INVALID" : "SOME",
830 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
832 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
833 See Info anchor `(elisp)Definition of signal' for some details on how this
834 error message is constructed. */)
837 struct buffer
*old
= current_buffer
;
841 /* If OBJ is (error STRING), just return STRING.
842 That is not only faster, it also avoids the need to allocate
843 space here when the error is due to memory full. */
844 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
845 && CONSP (XCDR (obj
))
846 && STRINGP (XCAR (XCDR (obj
)))
847 && NILP (XCDR (XCDR (obj
))))
848 return XCAR (XCDR (obj
));
850 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
852 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
853 value
= Fbuffer_string ();
857 set_buffer_internal (old
);
863 /* Print an error message for the error DATA onto Lisp output stream
864 STREAM (suitable for the print functions).
865 CONTEXT is a C string describing the context of the error.
866 CALLER is the Lisp function inside which the error was signaled. */
869 print_error_message (Lisp_Object data
, Lisp_Object stream
, const char *context
,
872 Lisp_Object errname
, errmsg
, file_error
, tail
;
876 write_string_1 (context
, -1, stream
);
878 /* If we know from where the error was signaled, show it in
880 if (!NILP (caller
) && SYMBOLP (caller
))
882 Lisp_Object cname
= SYMBOL_NAME (caller
);
883 ptrdiff_t cnamelen
= SBYTES (cname
);
885 char *name
= SAFE_ALLOCA (cnamelen
);
886 memcpy (name
, SDATA (cname
), cnamelen
);
887 message_dolog (name
, cnamelen
, 0, 0);
888 message_dolog (": ", 2, 0, 0);
892 errname
= Fcar (data
);
894 if (EQ (errname
, Qerror
))
899 errmsg
= Fcar (data
);
904 Lisp_Object error_conditions
= Fget (errname
, Qerror_conditions
);
905 errmsg
= Fget (errname
, Qerror_message
);
906 file_error
= Fmemq (Qfile_error
, error_conditions
);
909 /* Print an error message including the data items. */
911 tail
= Fcdr_safe (data
);
914 /* For file-error, make error message by concatenating
915 all the data items. They are all strings. */
916 if (!NILP (file_error
) && CONSP (tail
))
917 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
920 const char *sep
= ": ";
922 if (!STRINGP (errmsg
))
923 write_string_1 ("peculiar error", -1, stream
);
924 else if (SCHARS (errmsg
))
925 Fprinc (errmsg
, stream
);
929 for (; CONSP (tail
); tail
= XCDR (tail
), sep
= ", ")
934 write_string_1 (sep
, 2, stream
);
936 if (!NILP (file_error
)
937 || EQ (errname
, Qend_of_file
) || EQ (errname
, Quser_error
))
938 Fprinc (obj
, stream
);
940 Fprin1 (obj
, stream
);
950 * The buffer should be at least as large as the max string size of the
951 * largest float, printed in the biggest notation. This is undoubtedly
952 * 20d float_output_format, with the negative of the C-constant "HUGE"
955 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
957 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
958 * case of -1e307 in 20d float_output_format. What is one to do (short of
959 * re-writing _doprnt to be more sane)?
961 * Given the above, the buffer must be least FLOAT_TO_STRING_BUFSIZE bytes.
965 float_to_string (char *buf
, double data
)
971 /* Check for plus infinity in a way that won't lose
972 if there is no plus infinity. */
973 if (data
== data
/ 2 && data
> 1.0)
975 static char const infinity_string
[] = "1.0e+INF";
976 strcpy (buf
, infinity_string
);
977 return sizeof infinity_string
- 1;
979 /* Likewise for minus infinity. */
980 if (data
== data
/ 2 && data
< -1.0)
982 static char const minus_infinity_string
[] = "-1.0e+INF";
983 strcpy (buf
, minus_infinity_string
);
984 return sizeof minus_infinity_string
- 1;
986 /* Check for NaN in a way that won't fail if there are no NaNs. */
987 if (! (data
* 0.0 >= 0.0))
989 /* Prepend "-" if the NaN's sign bit is negative.
990 The sign bit of a double is the bit that is 1 in -0.0. */
991 static char const NaN_string
[] = "0.0e+NaN";
993 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
996 u_minus_zero
.d
= - 0.0;
997 for (i
= 0; i
< sizeof (double); i
++)
998 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
1005 strcpy (buf
+ negative
, NaN_string
);
1006 return negative
+ sizeof NaN_string
- 1;
1009 if (NILP (Vfloat_output_format
)
1010 || !STRINGP (Vfloat_output_format
))
1013 /* Generate the fewest number of digits that represent the
1014 floating point value without losing information. */
1015 len
= dtoastr (buf
, FLOAT_TO_STRING_BUFSIZE
- 2, 0, 0, data
);
1016 /* The decimal point must be printed, or the byte compiler can
1017 get confused (Bug#8033). */
1020 else /* oink oink */
1022 /* Check that the spec we have is fully valid.
1023 This means not only valid for printf,
1024 but meant for floats, and reasonable. */
1025 cp
= SSDATA (Vfloat_output_format
);
1034 /* Check the width specification. */
1036 if ('0' <= *cp
&& *cp
<= '9')
1041 width
= (width
* 10) + (*cp
++ - '0');
1042 if (DBL_DIG
< width
)
1045 while (*cp
>= '0' && *cp
<= '9');
1047 /* A precision of zero is valid only for %f. */
1048 if (width
== 0 && *cp
!= 'f')
1052 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1058 len
= sprintf (buf
, SSDATA (Vfloat_output_format
), data
);
1061 /* Make sure there is a decimal point with digit after, or an
1062 exponent, so that the value is readable as a float. But don't do
1063 this with "%.0f"; it's valid for that not to produce a decimal
1064 point. Note that width can be 0 only for %.0f. */
1067 for (cp
= buf
; *cp
; cp
++)
1068 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1071 if (*cp
== '.' && cp
[1] == 0)
1091 print (Lisp_Object obj
, Lisp_Object printcharfun
, bool escapeflag
)
1093 new_backquote_output
= 0;
1095 /* Reset print_number_index and Vprint_number_table only when
1096 the variable Vprint_continuous_numbering is nil. Otherwise,
1097 the values of these variables will be kept between several
1099 if (NILP (Vprint_continuous_numbering
)
1100 || NILP (Vprint_number_table
))
1102 print_number_index
= 0;
1103 Vprint_number_table
= Qnil
;
1106 /* Construct Vprint_number_table for print-gensym and print-circle. */
1107 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1109 /* Construct Vprint_number_table.
1110 This increments print_number_index for the objects added. */
1112 print_preprocess (obj
);
1114 if (HASH_TABLE_P (Vprint_number_table
))
1115 { /* Remove unnecessary objects, which appear only once in OBJ;
1116 that is, whose status is Qt. */
1117 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vprint_number_table
);
1120 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
1121 if (!NILP (HASH_HASH (h
, i
))
1122 && EQ (HASH_VALUE (h
, i
), Qt
))
1123 Fremhash (HASH_KEY (h
, i
), Vprint_number_table
);
1128 print_object (obj
, printcharfun
, escapeflag
);
1131 #define PRINT_CIRCLE_CANDIDATE_P(obj) \
1132 (STRINGP (obj) || CONSP (obj) \
1133 || (VECTORLIKEP (obj) \
1134 && (VECTORP (obj) || COMPILEDP (obj) \
1135 || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \
1136 || HASH_TABLE_P (obj) || FONTP (obj))) \
1137 || (! NILP (Vprint_gensym) \
1139 && !SYMBOL_INTERNED_P (obj)))
1141 /* Construct Vprint_number_table according to the structure of OBJ.
1142 OBJ itself and all its elements will be added to Vprint_number_table
1143 recursively if it is a list, vector, compiled function, char-table,
1144 string (its text properties will be traced), or a symbol that has
1145 no obarray (this is for the print-gensym feature).
1146 The status fields of Vprint_number_table mean whether each object appears
1147 more than once in OBJ: Qnil at the first time, and Qt after that. */
1149 print_preprocess (Lisp_Object obj
)
1154 Lisp_Object halftail
;
1156 /* Avoid infinite recursion for circular nested structure
1157 in the case where Vprint_circle is nil. */
1158 if (NILP (Vprint_circle
))
1160 /* Give up if we go so deep that print_object will get an error. */
1161 /* See similar code in print_object. */
1162 if (print_depth
>= PRINT_CIRCLE
)
1163 error ("Apparently circular structure being printed");
1165 for (i
= 0; i
< print_depth
; i
++)
1166 if (EQ (obj
, being_printed
[i
]))
1168 being_printed
[print_depth
] = obj
;
1175 if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1177 if (!HASH_TABLE_P (Vprint_number_table
))
1179 Lisp_Object args
[2];
1182 Vprint_number_table
= Fmake_hash_table (2, args
);
1185 /* In case print-circle is nil and print-gensym is t,
1186 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1187 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1189 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1191 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1192 always print the gensym with a number. This is a special for
1193 the lisp function byte-compile-output-docform. */
1194 || (!NILP (Vprint_continuous_numbering
)
1196 && !SYMBOL_INTERNED_P (obj
)))
1197 { /* OBJ appears more than once. Let's remember that. */
1198 if (!INTEGERP (num
))
1200 print_number_index
++;
1201 /* Negative number indicates it hasn't been printed yet. */
1202 Fputhash (obj
, make_number (- print_number_index
),
1203 Vprint_number_table
);
1209 /* OBJ is not yet recorded. Let's add to the table. */
1210 Fputhash (obj
, Qt
, Vprint_number_table
);
1213 switch (XTYPE (obj
))
1216 /* A string may have text properties, which can be circular. */
1217 traverse_intervals_noorder (string_intervals (obj
),
1218 print_preprocess_string
, Qnil
);
1222 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1223 just as in print_object. */
1224 if (loop_count
&& EQ (obj
, halftail
))
1226 print_preprocess (XCAR (obj
));
1229 if (!(loop_count
& 1))
1230 halftail
= XCDR (halftail
);
1233 case Lisp_Vectorlike
:
1235 if (size
& PSEUDOVECTOR_FLAG
)
1236 size
&= PSEUDOVECTOR_SIZE_MASK
;
1237 for (i
= (SUB_CHAR_TABLE_P (obj
)
1238 ? SUB_CHAR_TABLE_OFFSET
: 0); i
< size
; i
++)
1239 print_preprocess (AREF (obj
, i
));
1240 if (HASH_TABLE_P (obj
))
1241 { /* For hash tables, the key_and_value slot is past
1242 `size' because it needs to be marked specially in case
1243 the table is weak. */
1244 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1245 print_preprocess (h
->key_and_value
);
1257 print_preprocess_string (INTERVAL interval
, Lisp_Object arg
)
1259 print_preprocess (interval
->plist
);
1262 static void print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
);
1264 #define PRINT_STRING_NON_CHARSET_FOUND 1
1265 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1267 /* Bitwise or of the above macros. */
1268 static int print_check_string_result
;
1271 print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
)
1275 if (NILP (interval
->plist
)
1276 || (print_check_string_result
== (PRINT_STRING_NON_CHARSET_FOUND
1277 | PRINT_STRING_UNSAFE_CHARSET_FOUND
)))
1279 for (val
= interval
->plist
; CONSP (val
) && ! EQ (XCAR (val
), Qcharset
);
1280 val
= XCDR (XCDR (val
)));
1283 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1286 if (! (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
))
1288 if (! EQ (val
, interval
->plist
)
1289 || CONSP (XCDR (XCDR (val
))))
1290 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1292 if (NILP (Vprint_charset_text_property
)
1293 || ! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1296 ptrdiff_t charpos
= interval
->position
;
1297 ptrdiff_t bytepos
= string_char_to_byte (string
, charpos
);
1298 Lisp_Object charset
;
1300 charset
= XCAR (XCDR (val
));
1301 for (i
= 0; i
< LENGTH (interval
); i
++)
1303 FETCH_STRING_CHAR_ADVANCE (c
, string
, charpos
, bytepos
);
1304 if (! ASCII_CHAR_P (c
)
1305 && ! EQ (CHARSET_NAME (CHAR_CHARSET (c
)), charset
))
1307 print_check_string_result
|= PRINT_STRING_UNSAFE_CHARSET_FOUND
;
1314 /* The value is (charset . nil). */
1315 static Lisp_Object print_prune_charset_plist
;
1318 print_prune_string_charset (Lisp_Object string
)
1320 print_check_string_result
= 0;
1321 traverse_intervals (string_intervals (string
), 0,
1322 print_check_string_charset_prop
, string
);
1323 if (! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1325 string
= Fcopy_sequence (string
);
1326 if (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
)
1328 if (NILP (print_prune_charset_plist
))
1329 print_prune_charset_plist
= list1 (Qcharset
);
1330 Fremove_text_properties (make_number (0),
1331 make_number (SCHARS (string
)),
1332 print_prune_charset_plist
, string
);
1335 Fset_text_properties (make_number (0), make_number (SCHARS (string
)),
1342 print_object (Lisp_Object obj
, Lisp_Object printcharfun
, bool escapeflag
)
1344 char buf
[max (sizeof "from..to..in " + 2 * INT_STRLEN_BOUND (EMACS_INT
),
1345 max (sizeof " . #" + INT_STRLEN_BOUND (printmax_t
),
1350 /* Detect circularities and truncate them. */
1351 if (NILP (Vprint_circle
))
1353 /* Simple but incomplete way. */
1356 /* See similar code in print_preprocess. */
1357 if (print_depth
>= PRINT_CIRCLE
)
1358 error ("Apparently circular structure being printed");
1360 for (i
= 0; i
< print_depth
; i
++)
1361 if (EQ (obj
, being_printed
[i
]))
1363 int len
= sprintf (buf
, "#%d", i
);
1364 strout (buf
, len
, len
, printcharfun
);
1367 being_printed
[print_depth
] = obj
;
1369 else if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1371 /* With the print-circle feature. */
1372 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1375 EMACS_INT n
= XINT (num
);
1377 { /* Add a prefix #n= if OBJ has not yet been printed;
1378 that is, its status field is nil. */
1379 int len
= sprintf (buf
, "#%"pI
"d=", -n
);
1380 strout (buf
, len
, len
, printcharfun
);
1381 /* OBJ is going to be printed. Remember that fact. */
1382 Fputhash (obj
, make_number (- n
), Vprint_number_table
);
1386 /* Just print #n# if OBJ has already been printed. */
1387 int len
= sprintf (buf
, "#%"pI
"d#", n
);
1388 strout (buf
, len
, len
, printcharfun
);
1396 switch (XTYPE (obj
))
1400 int len
= sprintf (buf
, "%"pI
"d", XINT (obj
));
1401 strout (buf
, len
, len
, printcharfun
);
1407 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
1408 int len
= float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1409 strout (pigbuf
, len
, len
, printcharfun
);
1415 print_string (obj
, printcharfun
);
1418 register ptrdiff_t i
, i_byte
;
1419 struct gcpro gcpro1
;
1420 ptrdiff_t size_byte
;
1421 /* 1 means we must ensure that the next character we output
1422 cannot be taken as part of a hex character escape. */
1423 bool need_nonhex
= 0;
1424 bool multibyte
= STRING_MULTIBYTE (obj
);
1428 if (! EQ (Vprint_charset_text_property
, Qt
))
1429 obj
= print_prune_string_charset (obj
);
1431 if (string_intervals (obj
))
1438 size_byte
= SBYTES (obj
);
1440 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1442 /* Here, we must convert each multi-byte form to the
1443 corresponding character code before handing it to PRINTCHAR. */
1446 FETCH_STRING_CHAR_ADVANCE (c
, obj
, i
, i_byte
);
1450 if (c
== '\n' && print_escape_newlines
)
1455 else if (c
== '\f' && print_escape_newlines
)
1461 && (CHAR_BYTE8_P (c
)
1462 || (! ASCII_CHAR_P (c
) && print_escape_multibyte
)))
1464 /* When multibyte is disabled,
1465 print multibyte string chars using hex escapes.
1466 For a char code that could be in a unibyte string,
1467 when found in a multibyte string, always use a hex escape
1468 so it reads back as multibyte. */
1472 if (CHAR_BYTE8_P (c
))
1473 len
= sprintf (outbuf
, "\\%03o", CHAR_TO_BYTE8 (c
));
1476 len
= sprintf (outbuf
, "\\x%04x", c
);
1479 strout (outbuf
, len
, len
, printcharfun
);
1481 else if (! multibyte
1482 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_CHAR_P (c
)
1483 && print_escape_nonascii
)
1485 /* When printing in a multibyte buffer
1486 or when explicitly requested,
1487 print single-byte non-ASCII string chars
1488 using octal escapes. */
1490 int len
= sprintf (outbuf
, "\\%03o", c
);
1491 strout (outbuf
, len
, len
, printcharfun
);
1495 /* If we just had a hex escape, and this character
1496 could be taken as part of it,
1497 output `\ ' to prevent that. */
1501 if ((c
>= 'a' && c
<= 'f')
1502 || (c
>= 'A' && c
<= 'F')
1503 || (c
>= '0' && c
<= '9'))
1504 strout ("\\ ", -1, -1, printcharfun
);
1507 if (c
== '\"' || c
== '\\')
1514 if (string_intervals (obj
))
1516 traverse_intervals (string_intervals (obj
),
1517 0, print_interval
, printcharfun
);
1528 unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1529 unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1531 ptrdiff_t i
, i_byte
;
1532 ptrdiff_t size_byte
;
1535 name
= SYMBOL_NAME (obj
);
1537 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1540 /* If symbol name begins with a digit, and ends with a digit,
1541 and contains nothing but digits and `e', it could be treated
1542 as a number. So set CONFUSING.
1544 Symbols that contain periods could also be taken as numbers,
1545 but periods are always escaped, so we don't have to worry
1547 else if (*p
>= '0' && *p
<= '9'
1548 && end
[-1] >= '0' && end
[-1] <= '9')
1550 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1551 /* Needed for \2e10. */
1552 || *p
== 'e' || *p
== 'E'))
1554 confusing
= (end
== p
);
1559 size_byte
= SBYTES (name
);
1561 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1566 else if (size_byte
== 0)
1573 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1575 /* Here, we must convert each multi-byte form to the
1576 corresponding character code before handing it to PRINTCHAR. */
1577 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1582 if (c
== '\"' || c
== '\\' || c
== '\''
1583 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1584 || c
== ',' || c
== '.' || c
== '`'
1585 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1587 PRINTCHAR ('\\'), confusing
= 0;
1595 /* If deeper than spec'd depth, print placeholder. */
1596 if (INTEGERP (Vprint_level
)
1597 && print_depth
> XINT (Vprint_level
))
1598 strout ("...", -1, -1, printcharfun
);
1599 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1600 && (EQ (XCAR (obj
), Qquote
)))
1603 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1605 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1606 && (EQ (XCAR (obj
), Qfunction
)))
1610 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1612 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1613 && ((EQ (XCAR (obj
), Qbackquote
))))
1615 print_object (XCAR (obj
), printcharfun
, 0);
1616 new_backquote_output
++;
1617 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1618 new_backquote_output
--;
1620 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1621 && new_backquote_output
1622 && ((EQ (XCAR (obj
), Qbackquote
)
1623 || EQ (XCAR (obj
), Qcomma
)
1624 || EQ (XCAR (obj
), Qcomma_at
)
1625 || EQ (XCAR (obj
), Qcomma_dot
))))
1627 print_object (XCAR (obj
), printcharfun
, 0);
1628 new_backquote_output
--;
1629 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1630 new_backquote_output
++;
1637 printmax_t i
, print_length
;
1638 Lisp_Object halftail
= obj
;
1640 /* Negative values of print-length are invalid in CL.
1641 Treat them like nil, as CMUCL does. */
1642 if (NATNUMP (Vprint_length
))
1643 print_length
= XFASTINT (Vprint_length
);
1645 print_length
= TYPE_MAXIMUM (printmax_t
);
1650 /* Detect circular list. */
1651 if (NILP (Vprint_circle
))
1653 /* Simple but incomplete way. */
1654 if (i
!= 0 && EQ (obj
, halftail
))
1656 int len
= sprintf (buf
, " . #%"pMd
, i
/ 2);
1657 strout (buf
, len
, len
, printcharfun
);
1663 /* With the print-circle feature. */
1666 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1669 strout (" . ", 3, 3, printcharfun
);
1670 print_object (obj
, printcharfun
, escapeflag
);
1679 if (print_length
<= i
)
1681 strout ("...", 3, 3, printcharfun
);
1686 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1690 halftail
= XCDR (halftail
);
1694 /* OBJ non-nil here means it's the end of a dotted list. */
1697 strout (" . ", 3, 3, printcharfun
);
1698 print_object (obj
, printcharfun
, escapeflag
);
1706 case Lisp_Vectorlike
:
1711 strout ("#<process ", -1, -1, printcharfun
);
1712 print_string (XPROCESS (obj
)->name
, printcharfun
);
1716 print_string (XPROCESS (obj
)->name
, printcharfun
);
1718 else if (BOOL_VECTOR_P (obj
))
1723 struct gcpro gcpro1
;
1724 EMACS_INT size
= bool_vector_size (obj
);
1725 ptrdiff_t size_in_chars
= bool_vector_bytes (size
);
1726 ptrdiff_t real_size_in_chars
= size_in_chars
;
1731 len
= sprintf (buf
, "%"pI
"d", size
);
1732 strout (buf
, len
, len
, printcharfun
);
1735 /* Don't print more characters than the specified maximum.
1736 Negative values of print-length are invalid. Treat them
1737 like a print-length of nil. */
1738 if (NATNUMP (Vprint_length
)
1739 && XFASTINT (Vprint_length
) < size_in_chars
)
1740 size_in_chars
= XFASTINT (Vprint_length
);
1742 for (i
= 0; i
< size_in_chars
; i
++)
1745 c
= bool_vector_uchar_data (obj
)[i
];
1746 if (c
== '\n' && print_escape_newlines
)
1751 else if (c
== '\f' && print_escape_newlines
)
1756 else if (c
> '\177')
1758 /* Use octal escapes to avoid encoding issues. */
1760 PRINTCHAR ('0' + ((c
>> 6) & 3));
1761 PRINTCHAR ('0' + ((c
>> 3) & 7));
1762 PRINTCHAR ('0' + (c
& 7));
1766 if (c
== '\"' || c
== '\\')
1772 if (size_in_chars
< real_size_in_chars
)
1773 strout (" ...", 4, 4, printcharfun
);
1778 else if (SUBRP (obj
))
1780 strout ("#<subr ", -1, -1, printcharfun
);
1781 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
);
1784 #ifdef HAVE_XWIDGETS
1785 else if (XWIDGETP (obj
))
1787 strout ("#<xwidget ", -1, -1, printcharfun
);
1790 else if (XWIDGET_VIEW_P (obj
))
1792 strout ("#<xwidget-view ", -1, -1, printcharfun
);
1796 else if (WINDOWP (obj
))
1799 strout ("#<window ", -1, -1, printcharfun
);
1800 len
= sprintf (buf
, "%d", XWINDOW (obj
)->sequence_number
);
1801 strout (buf
, len
, len
, printcharfun
);
1802 if (BUFFERP (XWINDOW (obj
)->contents
))
1804 strout (" on ", -1, -1, printcharfun
);
1805 print_string (BVAR (XBUFFER (XWINDOW (obj
)->contents
), name
),
1810 else if (TERMINALP (obj
))
1813 struct terminal
*t
= XTERMINAL (obj
);
1814 strout ("#<terminal ", -1, -1, printcharfun
);
1815 len
= sprintf (buf
, "%d", t
->id
);
1816 strout (buf
, len
, len
, printcharfun
);
1819 strout (" on ", -1, -1, printcharfun
);
1820 strout (t
->name
, -1, -1, printcharfun
);
1824 else if (HASH_TABLE_P (obj
))
1826 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1828 ptrdiff_t real_size
, size
;
1832 strout ("#<hash-table", -1, -1, printcharfun
);
1833 if (SYMBOLP (h
->test
))
1837 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
);
1839 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
);
1841 len
= sprintf (buf
, "%"pD
"d/%"pD
"d", h
->count
, ASIZE (h
->next
));
1842 strout (buf
, len
, len
, printcharfun
);
1844 len
= sprintf (buf
, " %p>", ptr
);
1845 strout (buf
, len
, len
, printcharfun
);
1847 /* Implement a readable output, e.g.:
1848 #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
1849 /* Always print the size. */
1850 len
= sprintf (buf
, "#s(hash-table size %"pD
"d", ASIZE (h
->next
));
1851 strout (buf
, len
, len
, printcharfun
);
1853 if (!NILP (h
->test
.name
))
1855 strout (" test ", -1, -1, printcharfun
);
1856 print_object (h
->test
.name
, printcharfun
, escapeflag
);
1859 if (!NILP (h
->weak
))
1861 strout (" weakness ", -1, -1, printcharfun
);
1862 print_object (h
->weak
, printcharfun
, escapeflag
);
1865 if (!NILP (h
->rehash_size
))
1867 strout (" rehash-size ", -1, -1, printcharfun
);
1868 print_object (h
->rehash_size
, printcharfun
, escapeflag
);
1871 if (!NILP (h
->rehash_threshold
))
1873 strout (" rehash-threshold ", -1, -1, printcharfun
);
1874 print_object (h
->rehash_threshold
, printcharfun
, escapeflag
);
1877 strout (" data ", -1, -1, printcharfun
);
1879 /* Print the data here as a plist. */
1880 real_size
= HASH_TABLE_SIZE (h
);
1883 /* Don't print more elements than the specified maximum. */
1884 if (NATNUMP (Vprint_length
)
1885 && XFASTINT (Vprint_length
) < size
)
1886 size
= XFASTINT (Vprint_length
);
1889 for (i
= 0; i
< size
; i
++)
1890 if (!NILP (HASH_HASH (h
, i
)))
1892 if (i
) PRINTCHAR (' ');
1893 print_object (HASH_KEY (h
, i
), printcharfun
, escapeflag
);
1895 print_object (HASH_VALUE (h
, i
), printcharfun
, escapeflag
);
1898 if (size
< real_size
)
1899 strout (" ...", 4, 4, printcharfun
);
1905 else if (BUFFERP (obj
))
1907 if (!BUFFER_LIVE_P (XBUFFER (obj
)))
1908 strout ("#<killed buffer>", -1, -1, printcharfun
);
1909 else if (escapeflag
)
1911 strout ("#<buffer ", -1, -1, printcharfun
);
1912 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1916 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1918 else if (WINDOW_CONFIGURATIONP (obj
))
1920 strout ("#<window-configuration>", -1, -1, printcharfun
);
1922 else if (FRAMEP (obj
))
1925 void *ptr
= XFRAME (obj
);
1926 Lisp_Object frame_name
= XFRAME (obj
)->name
;
1928 strout ((FRAME_LIVE_P (XFRAME (obj
))
1929 ? "#<frame " : "#<dead frame "),
1930 -1, -1, printcharfun
);
1931 if (!STRINGP (frame_name
))
1933 /* A frame could be too young and have no name yet;
1935 if (SYMBOLP (frame_name
))
1936 frame_name
= Fsymbol_name (frame_name
);
1937 else /* can't happen: name should be either nil or string */
1938 frame_name
= build_string ("*INVALID*FRAME*NAME*");
1940 print_string (frame_name
, printcharfun
);
1941 len
= sprintf (buf
, " %p>", ptr
);
1942 strout (buf
, len
, len
, printcharfun
);
1944 else if (FONTP (obj
))
1948 if (! FONT_OBJECT_P (obj
))
1950 if (FONT_SPEC_P (obj
))
1951 strout ("#<font-spec", -1, -1, printcharfun
);
1953 strout ("#<font-entity", -1, -1, printcharfun
);
1954 for (i
= 0; i
< FONT_SPEC_MAX
; i
++)
1957 if (i
< FONT_WEIGHT_INDEX
|| i
> FONT_WIDTH_INDEX
)
1958 print_object (AREF (obj
, i
), printcharfun
, escapeflag
);
1960 print_object (font_style_symbolic (obj
, i
, 0),
1961 printcharfun
, escapeflag
);
1966 strout ("#<font-object ", -1, -1, printcharfun
);
1967 print_object (AREF (obj
, FONT_NAME_INDEX
), printcharfun
,
1974 ptrdiff_t size
= ASIZE (obj
);
1975 if (COMPILEDP (obj
))
1978 size
&= PSEUDOVECTOR_SIZE_MASK
;
1980 if (CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
))
1982 /* We print a char-table as if it were a vector,
1983 lumping the parent and default slots in with the
1984 character slots. But we add #^ as a prefix. */
1986 /* Make each lowest sub_char_table start a new line.
1987 Otherwise we'll make a line extremely long, which
1988 results in slow redisplay. */
1989 if (SUB_CHAR_TABLE_P (obj
)
1990 && XSUB_CHAR_TABLE (obj
)->depth
== 3)
1994 if (SUB_CHAR_TABLE_P (obj
))
1996 size
&= PSEUDOVECTOR_SIZE_MASK
;
1998 if (size
& PSEUDOVECTOR_FLAG
)
2003 int i
, idx
= SUB_CHAR_TABLE_P (obj
) ? SUB_CHAR_TABLE_OFFSET
: 0;
2004 register Lisp_Object tem
;
2005 ptrdiff_t real_size
= size
;
2007 /* For a sub char-table, print heading non-Lisp data first. */
2008 if (SUB_CHAR_TABLE_P (obj
))
2010 i
= sprintf (buf
, "%d %d", XSUB_CHAR_TABLE (obj
)->depth
,
2011 XSUB_CHAR_TABLE (obj
)->min_char
);
2012 strout (buf
, i
, i
, printcharfun
);
2015 /* Don't print more elements than the specified maximum. */
2016 if (NATNUMP (Vprint_length
)
2017 && XFASTINT (Vprint_length
) < size
)
2018 size
= XFASTINT (Vprint_length
);
2020 for (i
= idx
; i
< size
; i
++)
2022 if (i
) PRINTCHAR (' ');
2023 tem
= AREF (obj
, i
);
2024 print_object (tem
, printcharfun
, escapeflag
);
2026 if (size
< real_size
)
2027 strout (" ...", 4, 4, printcharfun
);
2034 switch (XMISCTYPE (obj
))
2036 case Lisp_Misc_Marker
:
2037 strout ("#<marker ", -1, -1, printcharfun
);
2038 /* Do you think this is necessary? */
2039 if (XMARKER (obj
)->insertion_type
!= 0)
2040 strout ("(moves after insertion) ", -1, -1, printcharfun
);
2041 if (! XMARKER (obj
)->buffer
)
2042 strout ("in no buffer", -1, -1, printcharfun
);
2045 int len
= sprintf (buf
, "at %"pD
"d", marker_position (obj
));
2046 strout (buf
, len
, len
, printcharfun
);
2047 strout (" in ", -1, -1, printcharfun
);
2048 print_string (BVAR (XMARKER (obj
)->buffer
, name
), printcharfun
);
2053 case Lisp_Misc_Overlay
:
2054 strout ("#<overlay ", -1, -1, printcharfun
);
2055 if (! XMARKER (OVERLAY_START (obj
))->buffer
)
2056 strout ("in no buffer", -1, -1, printcharfun
);
2059 int len
= sprintf (buf
, "from %"pD
"d to %"pD
"d in ",
2060 marker_position (OVERLAY_START (obj
)),
2061 marker_position (OVERLAY_END (obj
)));
2062 strout (buf
, len
, len
, printcharfun
);
2063 print_string (BVAR (XMARKER (OVERLAY_START (obj
))->buffer
, name
),
2069 /* Remaining cases shouldn't happen in normal usage, but let's
2070 print them anyway for the benefit of the debugger. */
2072 case Lisp_Misc_Free
:
2073 strout ("#<misc free cell>", -1, -1, printcharfun
);
2076 case Lisp_Misc_Save_Value
:
2079 struct Lisp_Save_Value
*v
= XSAVE_VALUE (obj
);
2081 strout ("#<save-value ", -1, -1, printcharfun
);
2083 if (v
->save_type
== SAVE_TYPE_MEMORY
)
2085 ptrdiff_t amount
= v
->data
[1].integer
;
2089 /* valid_lisp_object_p is reliable, so try to print up
2090 to 8 saved objects. This code is rarely used, so
2091 it's OK that valid_lisp_object_p is slow. */
2093 int limit
= min (amount
, 8);
2094 Lisp_Object
*area
= v
->data
[0].pointer
;
2096 i
= sprintf (buf
, "with %"pD
"d objects", amount
);
2097 strout (buf
, i
, i
, printcharfun
);
2099 for (i
= 0; i
< limit
; i
++)
2101 Lisp_Object maybe
= area
[i
];
2102 int valid
= valid_lisp_object_p (maybe
);
2107 print_object (maybe
, printcharfun
, escapeflag
);
2110 strout (valid
? " <some>" : " <invalid>",
2111 -1, -1, printcharfun
);
2113 if (i
== limit
&& i
< amount
)
2114 strout (" ...", 4, 4, printcharfun
);
2116 #else /* not GC_MARK_STACK */
2118 /* There is no reliable way to determine whether the objects
2119 are initialized, so do not try to print them. */
2121 i
= sprintf (buf
, "with %"pD
"d objects", amount
);
2122 strout (buf
, i
, i
, printcharfun
);
2124 #endif /* GC_MARK_STACK */
2128 /* Print each slot according to its type. */
2130 for (index
= 0; index
< SAVE_VALUE_SLOTS
; index
++)
2135 switch (save_type (v
, index
))
2138 i
= sprintf (buf
, "<unused>");
2142 i
= sprintf (buf
, "<pointer %p>",
2143 v
->data
[index
].pointer
);
2146 case SAVE_FUNCPOINTER
:
2147 i
= sprintf (buf
, "<funcpointer %p>",
2148 ((void *) (intptr_t)
2149 v
->data
[index
].funcpointer
));
2153 i
= sprintf (buf
, "<integer %"pD
"d>",
2154 v
->data
[index
].integer
);
2158 print_object (v
->data
[index
].object
, printcharfun
,
2166 strout (buf
, i
, i
, printcharfun
);
2182 /* We're in trouble if this happens!
2183 Probably should just emacs_abort (). */
2184 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
);
2186 len
= sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2187 else if (VECTORLIKEP (obj
))
2188 len
= sprintf (buf
, "(PVEC 0x%08"pD
"x)", ASIZE (obj
));
2190 len
= sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2191 strout (buf
, len
, len
, printcharfun
);
2192 strout (" Save your buffers immediately and please report this bug>",
2193 -1, -1, printcharfun
);
2201 /* Print a description of INTERVAL using PRINTCHARFUN.
2202 This is part of printing a string that has text properties. */
2205 print_interval (INTERVAL interval
, Lisp_Object printcharfun
)
2207 if (NILP (interval
->plist
))
2210 print_object (make_number (interval
->position
), printcharfun
, 1);
2212 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2215 print_object (interval
->plist
, printcharfun
, 1);
2218 /* Initialize debug_print stuff early to have it working from the very
2222 init_print_once (void)
2224 /* The subroutine object for external-debugging-output is kept here
2225 for the convenience of the debugger. */
2226 DEFSYM (Qexternal_debugging_output
, "external-debugging-output");
2228 defsubr (&Sexternal_debugging_output
);
2232 syms_of_print (void)
2234 DEFSYM (Qtemp_buffer_setup_hook
, "temp-buffer-setup-hook");
2236 DEFVAR_LISP ("standard-output", Vstandard_output
,
2237 doc
: /* Output stream `print' uses by default for outputting a character.
2238 This may be any function of one argument.
2239 It may also be a buffer (output is inserted before point)
2240 or a marker (output is inserted and the marker is advanced)
2241 or the symbol t (output appears in the echo area). */);
2242 Vstandard_output
= Qt
;
2243 DEFSYM (Qstandard_output
, "standard-output");
2245 DEFVAR_LISP ("float-output-format", Vfloat_output_format
,
2246 doc
: /* The format descriptor string used to print floats.
2247 This is a %-spec like those accepted by `printf' in C,
2248 but with some restrictions. It must start with the two characters `%.'.
2249 After that comes an integer precision specification,
2250 and then a letter which controls the format.
2251 The letters allowed are `e', `f' and `g'.
2252 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2253 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2254 Use `g' to choose the shorter of those two formats for the number at hand.
2255 The precision in any of these cases is the number of digits following
2256 the decimal point. With `f', a precision of 0 means to omit the
2257 decimal point. 0 is not allowed with `e' or `g'.
2259 A value of nil means to use the shortest notation
2260 that represents the number without losing information. */);
2261 Vfloat_output_format
= Qnil
;
2262 DEFSYM (Qfloat_output_format
, "float-output-format");
2264 DEFVAR_LISP ("print-length", Vprint_length
,
2265 doc
: /* Maximum length of list to print before abbreviating.
2266 A value of nil means no limit. See also `eval-expression-print-length'. */);
2267 Vprint_length
= Qnil
;
2269 DEFVAR_LISP ("print-level", Vprint_level
,
2270 doc
: /* Maximum depth of list nesting to print before abbreviating.
2271 A value of nil means no limit. See also `eval-expression-print-level'. */);
2272 Vprint_level
= Qnil
;
2274 DEFVAR_BOOL ("print-escape-newlines", print_escape_newlines
,
2275 doc
: /* Non-nil means print newlines in strings as `\\n'.
2276 Also print formfeeds as `\\f'. */);
2277 print_escape_newlines
= 0;
2279 DEFVAR_BOOL ("print-escape-nonascii", print_escape_nonascii
,
2280 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2281 \(OOO is the octal representation of the character code.)
2282 Only single-byte characters are affected, and only in `prin1'.
2283 When the output goes in a multibyte buffer, this feature is
2284 enabled regardless of the value of the variable. */);
2285 print_escape_nonascii
= 0;
2287 DEFVAR_BOOL ("print-escape-multibyte", print_escape_multibyte
,
2288 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2289 \(XXXX is the hex representation of the character code.)
2290 This affects only `prin1'. */);
2291 print_escape_multibyte
= 0;
2293 DEFVAR_BOOL ("print-quoted", print_quoted
,
2294 doc
: /* Non-nil means print quoted forms with reader syntax.
2295 I.e., (quote foo) prints as 'foo, (function foo) as #'foo. */);
2298 DEFVAR_LISP ("print-gensym", Vprint_gensym
,
2299 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2300 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2301 When the uninterned symbol appears within a recursive data structure,
2302 and the symbol appears more than once, in addition use the #N# and #N=
2303 constructs as needed, so that multiple references to the same symbol are
2304 shared once again when the text is read back. */);
2305 Vprint_gensym
= Qnil
;
2307 DEFVAR_LISP ("print-circle", Vprint_circle
,
2308 doc
: /* Non-nil means print recursive structures using #N= and #N# syntax.
2309 If nil, printing proceeds recursively and may lead to
2310 `max-lisp-eval-depth' being exceeded or an error may occur:
2311 \"Apparently circular structure being printed.\" Also see
2312 `print-length' and `print-level'.
2313 If non-nil, shared substructures anywhere in the structure are printed
2314 with `#N=' before the first occurrence (in the order of the print
2315 representation) and `#N#' in place of each subsequent occurrence,
2316 where N is a positive decimal integer. */);
2317 Vprint_circle
= Qnil
;
2319 DEFVAR_LISP ("print-continuous-numbering", Vprint_continuous_numbering
,
2320 doc
: /* Non-nil means number continuously across print calls.
2321 This affects the numbers printed for #N= labels and #M# references.
2322 See also `print-circle', `print-gensym', and `print-number-table'.
2323 This variable should not be set with `setq'; bind it with a `let' instead. */);
2324 Vprint_continuous_numbering
= Qnil
;
2326 DEFVAR_LISP ("print-number-table", Vprint_number_table
,
2327 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2328 The Lisp printer uses this vector to detect Lisp objects referenced more
2331 When you bind `print-continuous-numbering' to t, you should probably
2332 also bind `print-number-table' to nil. This ensures that the value of
2333 `print-number-table' can be garbage-collected once the printing is
2334 done. If all elements of `print-number-table' are nil, it means that
2335 the printing done so far has not found any shared structure or objects
2336 that need to be recorded in the table. */);
2337 Vprint_number_table
= Qnil
;
2339 DEFVAR_LISP ("print-charset-text-property", Vprint_charset_text_property
,
2340 doc
: /* A flag to control printing of `charset' text property on printing a string.
2341 The value must be nil, t, or `default'.
2343 If the value is nil, don't print the text property `charset'.
2345 If the value is t, always print the text property `charset'.
2347 If the value is `default', print the text property `charset' only when
2348 the value is different from what is guessed in the current charset
2350 Vprint_charset_text_property
= Qdefault
;
2352 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2353 staticpro (&Vprin1_to_string_buffer
);
2356 defsubr (&Sprin1_to_string
);
2357 defsubr (&Serror_message_string
);
2361 defsubr (&Swrite_char
);
2362 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2363 defsubr (&Sredirect_debugging_output
);
2366 DEFSYM (Qprint_escape_newlines
, "print-escape-newlines");
2367 DEFSYM (Qprint_escape_multibyte
, "print-escape-multibyte");
2368 DEFSYM (Qprint_escape_nonascii
, "print-escape-nonascii");
2370 print_prune_charset_plist
= Qnil
;
2371 staticpro (&print_prune_charset_plist
);