1 /* Lisp object printing and output streams.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2014 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. */
40 Lisp_Object Qstandard_output
;
42 static Lisp_Object Qtemp_buffer_setup_hook
;
44 /* These are used to print like we read. */
46 static Lisp_Object Qfloat_output_format
;
51 /* Avoid actual stack overflow in print. */
52 static ptrdiff_t print_depth
;
54 /* Level of nesting inside outputting backquote in new style. */
55 static ptrdiff_t new_backquote_output
;
57 /* Detect most circularities to print finite output. */
58 #define PRINT_CIRCLE 200
59 static Lisp_Object being_printed
[PRINT_CIRCLE
];
61 /* When printing into a buffer, first we put the text in this
62 block, then insert it all at once. */
63 static char *print_buffer
;
65 /* Size allocated in print_buffer. */
66 static ptrdiff_t print_buffer_size
;
67 /* Chars stored in print_buffer. */
68 static ptrdiff_t print_buffer_pos
;
69 /* Bytes stored in print_buffer. */
70 static ptrdiff_t print_buffer_pos_byte
;
72 Lisp_Object Qprint_escape_newlines
;
73 static Lisp_Object Qprint_escape_multibyte
, Qprint_escape_nonascii
;
75 /* Vprint_number_table is a table, that keeps objects that are going to
76 be printed, to allow use of #n= and #n# to express sharing.
77 For any given object, the table can give the following values:
78 t the object will be printed only once.
79 -N the object will be printed several times and will take number N.
80 N the object has been printed so we can refer to it as #N#.
81 print_number_index holds the largest N already used.
82 N has to be striclty larger than 0 since we need to distinguish -N. */
83 static ptrdiff_t print_number_index
;
84 static void print_interval (INTERVAL interval
, Lisp_Object printcharfun
);
86 /* GDB resets this to zero on W32 to disable OutputDebugString calls. */
87 bool print_output_debug_flag EXTERNALLY_VISIBLE
= 1;
90 /* Low level output routines for characters and strings. */
92 /* Lisp functions to do output using a stream
93 must have the stream in a variable called printcharfun
94 and must start with PRINTPREPARE, end with PRINTFINISH,
95 and use PRINTDECLARE to declare common variables.
96 Use PRINTCHAR to output one character,
97 or call strout to output a block of characters. */
99 #define PRINTDECLARE \
100 struct buffer *old = current_buffer; \
101 ptrdiff_t old_point = -1, start_point = -1; \
102 ptrdiff_t old_point_byte = -1, start_point_byte = -1; \
103 ptrdiff_t specpdl_count = SPECPDL_INDEX (); \
104 bool free_print_buffer = 0; \
106 = !NILP (BVAR (current_buffer, enable_multibyte_characters)); \
109 #define PRINTPREPARE \
110 original = printcharfun; \
111 if (NILP (printcharfun)) printcharfun = Qt; \
112 if (BUFFERP (printcharfun)) \
114 if (XBUFFER (printcharfun) != current_buffer) \
115 Fset_buffer (printcharfun); \
116 printcharfun = Qnil; \
118 if (MARKERP (printcharfun)) \
120 ptrdiff_t marker_pos; \
121 if (! XMARKER (printcharfun)->buffer) \
122 error ("Marker does not point anywhere"); \
123 if (XMARKER (printcharfun)->buffer != current_buffer) \
124 set_buffer_internal (XMARKER (printcharfun)->buffer); \
125 marker_pos = marker_position (printcharfun); \
126 if (marker_pos < BEGV || marker_pos > ZV) \
127 signal_error ("Marker is outside the accessible " \
128 "part of the buffer", printcharfun); \
130 old_point_byte = PT_BYTE; \
131 SET_PT_BOTH (marker_pos, \
132 marker_byte_position (printcharfun)); \
134 start_point_byte = PT_BYTE; \
135 printcharfun = Qnil; \
137 if (NILP (printcharfun)) \
139 Lisp_Object string; \
140 if (NILP (BVAR (current_buffer, enable_multibyte_characters)) \
141 && ! print_escape_multibyte) \
142 specbind (Qprint_escape_multibyte, Qt); \
143 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)) \
144 && ! print_escape_nonascii) \
145 specbind (Qprint_escape_nonascii, Qt); \
146 if (print_buffer != 0) \
148 string = make_string_from_bytes (print_buffer, \
150 print_buffer_pos_byte); \
151 record_unwind_protect (print_unwind, string); \
155 int new_size = 1000; \
156 print_buffer = xmalloc (new_size); \
157 print_buffer_size = new_size; \
158 free_print_buffer = 1; \
160 print_buffer_pos = 0; \
161 print_buffer_pos_byte = 0; \
163 if (EQ (printcharfun, Qt) && ! noninteractive) \
164 setup_echo_area_for_printing (multibyte);
166 #define PRINTFINISH \
167 if (NILP (printcharfun)) \
169 if (print_buffer_pos != print_buffer_pos_byte \
170 && NILP (BVAR (current_buffer, enable_multibyte_characters)))\
173 unsigned char *temp = SAFE_ALLOCA (print_buffer_pos + 1); \
174 copy_text ((unsigned char *) print_buffer, temp, \
175 print_buffer_pos_byte, 1, 0); \
176 insert_1_both ((char *) temp, print_buffer_pos, \
177 print_buffer_pos, 0, 1, 0); \
181 insert_1_both (print_buffer, print_buffer_pos, \
182 print_buffer_pos_byte, 0, 1, 0); \
183 signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
185 if (free_print_buffer) \
187 xfree (print_buffer); \
190 unbind_to (specpdl_count, Qnil); \
191 if (MARKERP (original)) \
192 set_marker_both (original, Qnil, PT, PT_BYTE); \
193 if (old_point >= 0) \
194 SET_PT_BOTH (old_point + (old_point >= start_point \
195 ? PT - start_point : 0), \
196 old_point_byte + (old_point_byte >= start_point_byte \
197 ? PT_BYTE - start_point_byte : 0)); \
198 set_buffer_internal (old);
200 #define PRINTCHAR(ch) printchar (ch, printcharfun)
202 /* This is used to restore the saved contents of print_buffer
203 when there is a recursive call to print. */
206 print_unwind (Lisp_Object saved_text
)
208 memcpy (print_buffer
, SDATA (saved_text
), SCHARS (saved_text
));
212 /* Print character CH using method FUN. FUN nil means print to
213 print_buffer. FUN t means print to echo area or stdout if
214 non-interactive. If FUN is neither nil nor t, call FUN with CH as
218 printchar (unsigned int ch
, Lisp_Object fun
)
220 if (!NILP (fun
) && !EQ (fun
, Qt
))
221 call1 (fun
, make_number (ch
));
224 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
225 int len
= CHAR_STRING (ch
, str
);
231 ptrdiff_t incr
= len
- (print_buffer_size
- print_buffer_pos_byte
);
233 print_buffer
= xpalloc (print_buffer
, &print_buffer_size
,
235 memcpy (print_buffer
+ print_buffer_pos_byte
, str
, len
);
236 print_buffer_pos
+= 1;
237 print_buffer_pos_byte
+= len
;
239 else if (noninteractive
)
241 fwrite (str
, 1, len
, stdout
);
242 noninteractive_need_newline
= 1;
247 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
249 setup_echo_area_for_printing (multibyte_p
);
251 message_dolog ((char *) str
, len
, 0, multibyte_p
);
257 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
258 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
259 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
260 print_buffer. PRINTCHARFUN t means output to the echo area or to
261 stdout if non-interactive. If neither nil nor t, call Lisp
262 function PRINTCHARFUN for each character printed. MULTIBYTE
263 non-zero means PTR contains multibyte characters.
265 In the case where PRINTCHARFUN is nil, it is safe for PTR to point
266 to data in a Lisp string. Otherwise that is not safe. */
269 strout (const char *ptr
, ptrdiff_t size
, ptrdiff_t size_byte
,
270 Lisp_Object printcharfun
)
273 size_byte
= size
= strlen (ptr
);
275 if (NILP (printcharfun
))
277 ptrdiff_t incr
= size_byte
- (print_buffer_size
- print_buffer_pos_byte
);
279 print_buffer
= xpalloc (print_buffer
, &print_buffer_size
, incr
, -1, 1);
280 memcpy (print_buffer
+ print_buffer_pos_byte
, ptr
, size_byte
);
281 print_buffer_pos
+= size
;
282 print_buffer_pos_byte
+= size_byte
;
284 else if (noninteractive
&& EQ (printcharfun
, Qt
))
286 fwrite (ptr
, 1, size_byte
, stdout
);
287 noninteractive_need_newline
= 1;
289 else if (EQ (printcharfun
, Qt
))
291 /* Output to echo area. We're trying to avoid a little overhead
292 here, that's the reason we don't call printchar to do the
296 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
298 setup_echo_area_for_printing (multibyte_p
);
299 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
301 if (size
== size_byte
)
303 for (i
= 0; i
< size
; ++i
)
304 insert_char ((unsigned char) *ptr
++);
309 for (i
= 0; i
< size_byte
; i
+= len
)
311 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
319 /* PRINTCHARFUN is a Lisp function. */
322 if (size
== size_byte
)
324 while (i
< size_byte
)
332 while (i
< size_byte
)
334 /* Here, we must convert each multi-byte form to the
335 corresponding character code before handing it to
338 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
347 /* Print the contents of a string STRING using PRINTCHARFUN.
348 It isn't safe to use strout in many cases,
349 because printing one char can relocate. */
352 print_string (Lisp_Object string
, Lisp_Object printcharfun
)
354 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
358 if (print_escape_nonascii
)
359 string
= string_escape_byte8 (string
);
361 if (STRING_MULTIBYTE (string
))
362 chars
= SCHARS (string
);
363 else if (! print_escape_nonascii
364 && (EQ (printcharfun
, Qt
)
365 ? ! NILP (BVAR (&buffer_defaults
, enable_multibyte_characters
))
366 : ! NILP (BVAR (current_buffer
, enable_multibyte_characters
))))
368 /* If unibyte string STRING contains 8-bit codes, we must
369 convert STRING to a multibyte string containing the same
374 chars
= SBYTES (string
);
375 bytes
= count_size_as_multibyte (SDATA (string
), chars
);
378 newstr
= make_uninit_multibyte_string (chars
, bytes
);
379 memcpy (SDATA (newstr
), SDATA (string
), chars
);
380 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
385 chars
= SBYTES (string
);
387 if (EQ (printcharfun
, Qt
))
389 /* Output to echo area. */
390 ptrdiff_t nbytes
= SBYTES (string
);
392 /* Copy the string contents so that relocation of STRING by
393 GC does not cause trouble. */
395 char *buffer
= SAFE_ALLOCA (nbytes
);
396 memcpy (buffer
, SDATA (string
), nbytes
);
398 strout (buffer
, chars
, nbytes
, printcharfun
);
403 /* No need to copy, since output to print_buffer can't GC. */
404 strout (SSDATA (string
), chars
, SBYTES (string
), printcharfun
);
408 /* Otherwise, string may be relocated by printing one char.
409 So re-fetch the string address for each character. */
411 ptrdiff_t size
= SCHARS (string
);
412 ptrdiff_t size_byte
= SBYTES (string
);
415 if (size
== size_byte
)
416 for (i
= 0; i
< size
; i
++)
417 PRINTCHAR (SREF (string
, i
));
419 for (i
= 0; i
< size_byte
; )
421 /* Here, we must convert each multi-byte form to the
422 corresponding character code before handing it to PRINTCHAR. */
424 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
, len
);
432 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
433 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
434 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
435 (Lisp_Object character
, Lisp_Object printcharfun
)
439 if (NILP (printcharfun
))
440 printcharfun
= Vstandard_output
;
441 CHECK_NUMBER (character
);
443 PRINTCHAR (XINT (character
));
448 /* Used from outside of print.c to print a block of SIZE
449 single-byte chars at DATA on the default output stream.
450 Do not use this on the contents of a Lisp string. */
453 write_string (const char *data
, int size
)
456 Lisp_Object printcharfun
;
458 printcharfun
= Vstandard_output
;
461 strout (data
, size
, size
, printcharfun
);
465 /* Used to print a block of SIZE single-byte chars at DATA on a
466 specified stream PRINTCHARFUN.
467 Do not use this on the contents of a Lisp string. */
470 write_string_1 (const char *data
, int size
, Lisp_Object printcharfun
)
475 strout (data
, size
, size
, printcharfun
);
481 temp_output_buffer_setup (const char *bufname
)
483 ptrdiff_t count
= SPECPDL_INDEX ();
484 register struct buffer
*old
= current_buffer
;
485 register Lisp_Object buf
;
487 record_unwind_current_buffer ();
489 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
491 Fkill_all_local_variables ();
492 delete_all_overlays (current_buffer
);
493 bset_directory (current_buffer
, BVAR (old
, directory
));
494 bset_read_only (current_buffer
, Qnil
);
495 bset_filename (current_buffer
, Qnil
);
496 bset_undo_list (current_buffer
, Qt
);
497 eassert (current_buffer
->overlays_before
== NULL
);
498 eassert (current_buffer
->overlays_after
== NULL
);
499 bset_enable_multibyte_characters
500 (current_buffer
, BVAR (&buffer_defaults
, enable_multibyte_characters
));
501 specbind (Qinhibit_read_only
, Qt
);
502 specbind (Qinhibit_modification_hooks
, Qt
);
504 XSETBUFFER (buf
, current_buffer
);
506 Frun_hooks (1, &Qtemp_buffer_setup_hook
);
508 unbind_to (count
, Qnil
);
510 specbind (Qstandard_output
, buf
);
513 static void print (Lisp_Object
, Lisp_Object
, bool);
514 static void print_preprocess (Lisp_Object
);
515 static void print_preprocess_string (INTERVAL
, Lisp_Object
);
516 static void print_object (Lisp_Object
, Lisp_Object
, bool);
518 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
519 doc
: /* Output a newline to stream PRINTCHARFUN.
520 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
521 (Lisp_Object printcharfun
)
525 if (NILP (printcharfun
))
526 printcharfun
= Vstandard_output
;
533 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
534 doc
: /* Output the printed representation of OBJECT, any Lisp object.
535 Quoting characters are printed when needed to make output that `read'
536 can handle, whenever this is possible. For complex objects, the behavior
537 is controlled by `print-level' and `print-length', which see.
539 OBJECT is any of the Lisp data types: a number, a string, a symbol,
540 a list, a buffer, a window, a frame, etc.
542 A printed representation of an object is text which describes that object.
544 Optional argument PRINTCHARFUN is the output stream, which can be one
547 - a buffer, in which case output is inserted into that buffer at point;
548 - a marker, in which case output is inserted at marker's position;
549 - a function, in which case that function is called once for each
550 character of OBJECT's printed representation;
551 - a symbol, in which case that symbol's function definition is called; or
552 - t, in which case the output is displayed in the echo area.
554 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
556 (Lisp_Object object
, Lisp_Object printcharfun
)
560 if (NILP (printcharfun
))
561 printcharfun
= Vstandard_output
;
563 print (object
, printcharfun
, 1);
568 /* a buffer which is used to hold output being built by prin1-to-string */
569 Lisp_Object Vprin1_to_string_buffer
;
571 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
572 doc
: /* Return a string containing the printed representation of OBJECT.
573 OBJECT can be any Lisp object. This function outputs quoting characters
574 when necessary to make output that `read' can handle, whenever possible,
575 unless the optional second argument NOESCAPE is non-nil. For complex objects,
576 the behavior is controlled by `print-level' and `print-length', which see.
578 OBJECT is any of the Lisp data types: a number, a string, a symbol,
579 a list, a buffer, a window, a frame, etc.
581 A printed representation of an object is text which describes that object. */)
582 (Lisp_Object object
, Lisp_Object noescape
)
584 Lisp_Object printcharfun
;
585 bool prev_abort_on_gc
;
586 Lisp_Object save_deactivate_mark
;
587 ptrdiff_t count
= SPECPDL_INDEX ();
588 struct buffer
*previous
;
590 specbind (Qinhibit_modification_hooks
, Qt
);
595 /* Save and restore this--we are altering a buffer
596 but we don't want to deactivate the mark just for that.
597 No need for specbind, since errors deactivate the mark. */
598 save_deactivate_mark
= Vdeactivate_mark
;
599 prev_abort_on_gc
= abort_on_gc
;
602 printcharfun
= Vprin1_to_string_buffer
;
604 print (object
, printcharfun
, NILP (noescape
));
605 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINISH */
609 previous
= current_buffer
;
610 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
611 object
= Fbuffer_string ();
612 if (SBYTES (object
) == SCHARS (object
))
613 STRING_SET_UNIBYTE (object
);
615 /* Note that this won't make prepare_to_modify_buffer call
616 ask-user-about-supersession-threat because this buffer
617 does not visit a file. */
619 set_buffer_internal (previous
);
621 Vdeactivate_mark
= save_deactivate_mark
;
623 abort_on_gc
= prev_abort_on_gc
;
624 return unbind_to (count
, object
);
627 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
628 doc
: /* Output the printed representation of OBJECT, any Lisp object.
629 No quoting characters are used; no delimiters are printed around
630 the contents of strings.
632 OBJECT is any of the Lisp data types: a number, a string, a symbol,
633 a list, a buffer, a window, a frame, etc.
635 A printed representation of an object is text which describes that object.
637 Optional argument PRINTCHARFUN is the output stream, which can be one
640 - a buffer, in which case output is inserted into that buffer at point;
641 - a marker, in which case output is inserted at marker's position;
642 - a function, in which case that function is called once for each
643 character of OBJECT's printed representation;
644 - a symbol, in which case that symbol's function definition is called; or
645 - t, in which case the output is displayed in the echo area.
647 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
649 (Lisp_Object object
, Lisp_Object printcharfun
)
653 if (NILP (printcharfun
))
654 printcharfun
= Vstandard_output
;
656 print (object
, printcharfun
, 0);
661 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
662 doc
: /* Output the printed representation of OBJECT, with newlines around it.
663 Quoting characters are printed when needed to make output that `read'
664 can handle, whenever this is possible. For complex objects, the behavior
665 is controlled by `print-level' and `print-length', which see.
667 OBJECT is any of the Lisp data types: a number, a string, a symbol,
668 a list, a buffer, a window, a frame, etc.
670 A printed representation of an object is text which describes that object.
672 Optional argument PRINTCHARFUN is the output stream, which can be one
675 - a buffer, in which case output is inserted into that buffer at point;
676 - a marker, in which case output is inserted at marker's position;
677 - a function, in which case that function is called once for each
678 character of OBJECT's printed representation;
679 - a symbol, in which case that symbol's function definition is called; or
680 - t, in which case the output is displayed in the echo area.
682 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
684 (Lisp_Object object
, Lisp_Object printcharfun
)
689 if (NILP (printcharfun
))
690 printcharfun
= Vstandard_output
;
694 print (object
, printcharfun
, 1);
701 /* The subroutine object for external-debugging-output is kept here
702 for the convenience of the debugger. */
703 Lisp_Object Qexternal_debugging_output
;
705 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
706 doc
: /* Write CHARACTER to stderr.
707 You can call print while debugging emacs, and pass it this function
708 to make it write to the debugging output. */)
709 (Lisp_Object character
)
713 CHECK_NUMBER (character
);
714 ch
= XINT (character
);
715 if (ASCII_CHAR_P (ch
))
719 /* Send the output to a debugger (nothing happens if there isn't
721 if (print_output_debug_flag
)
723 char buf
[2] = {(char) XINT (character
), '\0'};
724 OutputDebugString (buf
);
730 unsigned char mbstr
[MAX_MULTIBYTE_LENGTH
];
731 ptrdiff_t len
= CHAR_STRING (ch
, mbstr
);
732 Lisp_Object encoded_ch
=
733 ENCODE_SYSTEM (make_multibyte_string ((char *) mbstr
, 1, len
));
735 fwrite (SSDATA (encoded_ch
), SBYTES (encoded_ch
), 1, stderr
);
737 if (print_output_debug_flag
)
738 OutputDebugString (SSDATA (encoded_ch
));
745 /* This function is never called. Its purpose is to prevent
746 print_output_debug_flag from being optimized away. */
748 extern void debug_output_compilation_hack (bool) EXTERNALLY_VISIBLE
;
750 debug_output_compilation_hack (bool x
)
752 print_output_debug_flag
= x
;
755 #if defined (GNU_LINUX)
757 /* This functionality is not vitally important in general, so we rely on
758 non-portable ability to use stderr as lvalue. */
760 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
762 static FILE *initial_stderr_stream
= NULL
;
764 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
766 "FDebug output file: \nP",
767 doc
: /* Redirect debugging output (stderr stream) to file FILE.
768 If FILE is nil, reset target to the initial stderr stream.
769 Optional arg APPEND non-nil (interactively, with prefix arg) means
770 append to existing target file. */)
771 (Lisp_Object file
, Lisp_Object append
)
773 if (initial_stderr_stream
!= NULL
)
779 stderr
= initial_stderr_stream
;
780 initial_stderr_stream
= NULL
;
784 file
= Fexpand_file_name (file
, Qnil
);
785 initial_stderr_stream
= stderr
;
786 stderr
= emacs_fopen (SSDATA (file
), NILP (append
) ? "w" : "a");
789 stderr
= initial_stderr_stream
;
790 initial_stderr_stream
= NULL
;
791 report_file_error ("Cannot open debugging output stream", file
);
796 #endif /* GNU_LINUX */
799 /* This is the interface for debugging printing. */
802 debug_print (Lisp_Object arg
)
804 Fprin1 (arg
, Qexternal_debugging_output
);
805 fprintf (stderr
, "\r\n");
808 void safe_debug_print (Lisp_Object
) EXTERNALLY_VISIBLE
;
810 safe_debug_print (Lisp_Object arg
)
812 int valid
= valid_lisp_object_p (arg
);
817 fprintf (stderr
, "#<%s_LISP_OBJECT 0x%08"pI
"x>\r\n",
818 !valid
? "INVALID" : "SOME",
823 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
825 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
826 See Info anchor `(elisp)Definition of signal' for some details on how this
827 error message is constructed. */)
830 struct buffer
*old
= current_buffer
;
834 /* If OBJ is (error STRING), just return STRING.
835 That is not only faster, it also avoids the need to allocate
836 space here when the error is due to memory full. */
837 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
838 && CONSP (XCDR (obj
))
839 && STRINGP (XCAR (XCDR (obj
)))
840 && NILP (XCDR (XCDR (obj
))))
841 return XCAR (XCDR (obj
));
843 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
845 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
846 value
= Fbuffer_string ();
850 set_buffer_internal (old
);
856 /* Print an error message for the error DATA onto Lisp output stream
857 STREAM (suitable for the print functions).
858 CONTEXT is a C string describing the context of the error.
859 CALLER is the Lisp function inside which the error was signaled. */
862 print_error_message (Lisp_Object data
, Lisp_Object stream
, const char *context
,
865 Lisp_Object errname
, errmsg
, file_error
, tail
;
869 write_string_1 (context
, -1, stream
);
871 /* If we know from where the error was signaled, show it in
873 if (!NILP (caller
) && SYMBOLP (caller
))
875 Lisp_Object cname
= SYMBOL_NAME (caller
);
876 ptrdiff_t cnamelen
= SBYTES (cname
);
878 char *name
= SAFE_ALLOCA (cnamelen
);
879 memcpy (name
, SDATA (cname
), cnamelen
);
880 message_dolog (name
, cnamelen
, 0, 0);
881 message_dolog (": ", 2, 0, 0);
885 errname
= Fcar (data
);
887 if (EQ (errname
, Qerror
))
892 errmsg
= Fcar (data
);
897 Lisp_Object error_conditions
= Fget (errname
, Qerror_conditions
);
898 errmsg
= Fget (errname
, Qerror_message
);
899 file_error
= Fmemq (Qfile_error
, error_conditions
);
902 /* Print an error message including the data items. */
904 tail
= Fcdr_safe (data
);
907 /* For file-error, make error message by concatenating
908 all the data items. They are all strings. */
909 if (!NILP (file_error
) && CONSP (tail
))
910 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
913 const char *sep
= ": ";
915 if (!STRINGP (errmsg
))
916 write_string_1 ("peculiar error", -1, stream
);
917 else if (SCHARS (errmsg
))
918 Fprinc (errmsg
, stream
);
922 for (; CONSP (tail
); tail
= XCDR (tail
), sep
= ", ")
927 write_string_1 (sep
, 2, stream
);
929 if (!NILP (file_error
)
930 || EQ (errname
, Qend_of_file
) || EQ (errname
, Quser_error
))
931 Fprinc (obj
, stream
);
933 Fprin1 (obj
, stream
);
943 * The buffer should be at least as large as the max string size of the
944 * largest float, printed in the biggest notation. This is undoubtedly
945 * 20d float_output_format, with the negative of the C-constant "HUGE"
948 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
950 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
951 * case of -1e307 in 20d float_output_format. What is one to do (short of
952 * re-writing _doprnt to be more sane)?
954 * Given the above, the buffer must be least FLOAT_TO_STRING_BUFSIZE bytes.
958 float_to_string (char *buf
, double data
)
964 /* Check for plus infinity in a way that won't lose
965 if there is no plus infinity. */
966 if (data
== data
/ 2 && data
> 1.0)
968 static char const infinity_string
[] = "1.0e+INF";
969 strcpy (buf
, infinity_string
);
970 return sizeof infinity_string
- 1;
972 /* Likewise for minus infinity. */
973 if (data
== data
/ 2 && data
< -1.0)
975 static char const minus_infinity_string
[] = "-1.0e+INF";
976 strcpy (buf
, minus_infinity_string
);
977 return sizeof minus_infinity_string
- 1;
979 /* Check for NaN in a way that won't fail if there are no NaNs. */
980 if (! (data
* 0.0 >= 0.0))
982 /* Prepend "-" if the NaN's sign bit is negative.
983 The sign bit of a double is the bit that is 1 in -0.0. */
984 static char const NaN_string
[] = "0.0e+NaN";
986 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
989 u_minus_zero
.d
= - 0.0;
990 for (i
= 0; i
< sizeof (double); i
++)
991 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
998 strcpy (buf
+ negative
, NaN_string
);
999 return negative
+ sizeof NaN_string
- 1;
1002 if (NILP (Vfloat_output_format
)
1003 || !STRINGP (Vfloat_output_format
))
1006 /* Generate the fewest number of digits that represent the
1007 floating point value without losing information. */
1008 len
= dtoastr (buf
, FLOAT_TO_STRING_BUFSIZE
- 2, 0, 0, data
);
1009 /* The decimal point must be printed, or the byte compiler can
1010 get confused (Bug#8033). */
1013 else /* oink oink */
1015 /* Check that the spec we have is fully valid.
1016 This means not only valid for printf,
1017 but meant for floats, and reasonable. */
1018 cp
= SSDATA (Vfloat_output_format
);
1027 /* Check the width specification. */
1029 if ('0' <= *cp
&& *cp
<= '9')
1034 width
= (width
* 10) + (*cp
++ - '0');
1035 if (DBL_DIG
< width
)
1038 while (*cp
>= '0' && *cp
<= '9');
1040 /* A precision of zero is valid only for %f. */
1041 if (width
== 0 && *cp
!= 'f')
1045 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1051 len
= sprintf (buf
, SSDATA (Vfloat_output_format
), data
);
1054 /* Make sure there is a decimal point with digit after, or an
1055 exponent, so that the value is readable as a float. But don't do
1056 this with "%.0f"; it's valid for that not to produce a decimal
1057 point. Note that width can be 0 only for %.0f. */
1060 for (cp
= buf
; *cp
; cp
++)
1061 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1064 if (*cp
== '.' && cp
[1] == 0)
1084 print (Lisp_Object obj
, Lisp_Object printcharfun
, bool escapeflag
)
1086 new_backquote_output
= 0;
1088 /* Reset print_number_index and Vprint_number_table only when
1089 the variable Vprint_continuous_numbering is nil. Otherwise,
1090 the values of these variables will be kept between several
1092 if (NILP (Vprint_continuous_numbering
)
1093 || NILP (Vprint_number_table
))
1095 print_number_index
= 0;
1096 Vprint_number_table
= Qnil
;
1099 /* Construct Vprint_number_table for print-gensym and print-circle. */
1100 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1102 /* Construct Vprint_number_table.
1103 This increments print_number_index for the objects added. */
1105 print_preprocess (obj
);
1107 if (HASH_TABLE_P (Vprint_number_table
))
1108 { /* Remove unnecessary objects, which appear only once in OBJ;
1109 that is, whose status is Qt. */
1110 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vprint_number_table
);
1113 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
1114 if (!NILP (HASH_HASH (h
, i
))
1115 && EQ (HASH_VALUE (h
, i
), Qt
))
1116 Fremhash (HASH_KEY (h
, i
), Vprint_number_table
);
1121 print_object (obj
, printcharfun
, escapeflag
);
1124 #define PRINT_CIRCLE_CANDIDATE_P(obj) \
1125 (STRINGP (obj) || CONSP (obj) \
1126 || (VECTORLIKEP (obj) \
1127 && (VECTORP (obj) || COMPILEDP (obj) \
1128 || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \
1129 || HASH_TABLE_P (obj) || FONTP (obj))) \
1130 || (! NILP (Vprint_gensym) \
1132 && !SYMBOL_INTERNED_P (obj)))
1134 /* Construct Vprint_number_table according to the structure of OBJ.
1135 OBJ itself and all its elements will be added to Vprint_number_table
1136 recursively if it is a list, vector, compiled function, char-table,
1137 string (its text properties will be traced), or a symbol that has
1138 no obarray (this is for the print-gensym feature).
1139 The status fields of Vprint_number_table mean whether each object appears
1140 more than once in OBJ: Qnil at the first time, and Qt after that. */
1142 print_preprocess (Lisp_Object obj
)
1147 Lisp_Object halftail
;
1149 /* Avoid infinite recursion for circular nested structure
1150 in the case where Vprint_circle is nil. */
1151 if (NILP (Vprint_circle
))
1153 /* Give up if we go so deep that print_object will get an error. */
1154 /* See similar code in print_object. */
1155 if (print_depth
>= PRINT_CIRCLE
)
1156 error ("Apparently circular structure being printed");
1158 for (i
= 0; i
< print_depth
; i
++)
1159 if (EQ (obj
, being_printed
[i
]))
1161 being_printed
[print_depth
] = obj
;
1168 if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1170 if (!HASH_TABLE_P (Vprint_number_table
))
1172 Lisp_Object args
[2];
1175 Vprint_number_table
= Fmake_hash_table (2, args
);
1178 /* In case print-circle is nil and print-gensym is t,
1179 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1180 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1182 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1184 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1185 always print the gensym with a number. This is a special for
1186 the lisp function byte-compile-output-docform. */
1187 || (!NILP (Vprint_continuous_numbering
)
1189 && !SYMBOL_INTERNED_P (obj
)))
1190 { /* OBJ appears more than once. Let's remember that. */
1191 if (!INTEGERP (num
))
1193 print_number_index
++;
1194 /* Negative number indicates it hasn't been printed yet. */
1195 Fputhash (obj
, make_number (- print_number_index
),
1196 Vprint_number_table
);
1202 /* OBJ is not yet recorded. Let's add to the table. */
1203 Fputhash (obj
, Qt
, Vprint_number_table
);
1206 switch (XTYPE (obj
))
1209 /* A string may have text properties, which can be circular. */
1210 traverse_intervals_noorder (string_intervals (obj
),
1211 print_preprocess_string
, Qnil
);
1215 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1216 just as in print_object. */
1217 if (loop_count
&& EQ (obj
, halftail
))
1219 print_preprocess (XCAR (obj
));
1222 if (!(loop_count
& 1))
1223 halftail
= XCDR (halftail
);
1226 case Lisp_Vectorlike
:
1228 if (size
& PSEUDOVECTOR_FLAG
)
1229 size
&= PSEUDOVECTOR_SIZE_MASK
;
1230 for (i
= (SUB_CHAR_TABLE_P (obj
)
1231 ? SUB_CHAR_TABLE_OFFSET
: 0); i
< size
; i
++)
1232 print_preprocess (AREF (obj
, i
));
1233 if (HASH_TABLE_P (obj
))
1234 { /* For hash tables, the key_and_value slot is past
1235 `size' because it needs to be marked specially in case
1236 the table is weak. */
1237 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1238 print_preprocess (h
->key_and_value
);
1250 print_preprocess_string (INTERVAL interval
, Lisp_Object arg
)
1252 print_preprocess (interval
->plist
);
1255 static void print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
);
1257 #define PRINT_STRING_NON_CHARSET_FOUND 1
1258 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1260 /* Bitwise or of the above macros. */
1261 static int print_check_string_result
;
1264 print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
)
1268 if (NILP (interval
->plist
)
1269 || (print_check_string_result
== (PRINT_STRING_NON_CHARSET_FOUND
1270 | PRINT_STRING_UNSAFE_CHARSET_FOUND
)))
1272 for (val
= interval
->plist
; CONSP (val
) && ! EQ (XCAR (val
), Qcharset
);
1273 val
= XCDR (XCDR (val
)));
1276 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1279 if (! (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
))
1281 if (! EQ (val
, interval
->plist
)
1282 || CONSP (XCDR (XCDR (val
))))
1283 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1285 if (NILP (Vprint_charset_text_property
)
1286 || ! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1289 ptrdiff_t charpos
= interval
->position
;
1290 ptrdiff_t bytepos
= string_char_to_byte (string
, charpos
);
1291 Lisp_Object charset
;
1293 charset
= XCAR (XCDR (val
));
1294 for (i
= 0; i
< LENGTH (interval
); i
++)
1296 FETCH_STRING_CHAR_ADVANCE (c
, string
, charpos
, bytepos
);
1297 if (! ASCII_CHAR_P (c
)
1298 && ! EQ (CHARSET_NAME (CHAR_CHARSET (c
)), charset
))
1300 print_check_string_result
|= PRINT_STRING_UNSAFE_CHARSET_FOUND
;
1307 /* The value is (charset . nil). */
1308 static Lisp_Object print_prune_charset_plist
;
1311 print_prune_string_charset (Lisp_Object string
)
1313 print_check_string_result
= 0;
1314 traverse_intervals (string_intervals (string
), 0,
1315 print_check_string_charset_prop
, string
);
1316 if (! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1318 string
= Fcopy_sequence (string
);
1319 if (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
)
1321 if (NILP (print_prune_charset_plist
))
1322 print_prune_charset_plist
= list1 (Qcharset
);
1323 Fremove_text_properties (make_number (0),
1324 make_number (SCHARS (string
)),
1325 print_prune_charset_plist
, string
);
1328 Fset_text_properties (make_number (0), make_number (SCHARS (string
)),
1335 print_object (Lisp_Object obj
, Lisp_Object printcharfun
, bool escapeflag
)
1337 char buf
[max (sizeof "from..to..in " + 2 * INT_STRLEN_BOUND (EMACS_INT
),
1338 max (sizeof " . #" + INT_STRLEN_BOUND (printmax_t
),
1343 /* Detect circularities and truncate them. */
1344 if (NILP (Vprint_circle
))
1346 /* Simple but incomplete way. */
1349 /* See similar code in print_preprocess. */
1350 if (print_depth
>= PRINT_CIRCLE
)
1351 error ("Apparently circular structure being printed");
1353 for (i
= 0; i
< print_depth
; i
++)
1354 if (EQ (obj
, being_printed
[i
]))
1356 int len
= sprintf (buf
, "#%d", i
);
1357 strout (buf
, len
, len
, printcharfun
);
1360 being_printed
[print_depth
] = obj
;
1362 else if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1364 /* With the print-circle feature. */
1365 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1368 EMACS_INT n
= XINT (num
);
1370 { /* Add a prefix #n= if OBJ has not yet been printed;
1371 that is, its status field is nil. */
1372 int len
= sprintf (buf
, "#%"pI
"d=", -n
);
1373 strout (buf
, len
, len
, printcharfun
);
1374 /* OBJ is going to be printed. Remember that fact. */
1375 Fputhash (obj
, make_number (- n
), Vprint_number_table
);
1379 /* Just print #n# if OBJ has already been printed. */
1380 int len
= sprintf (buf
, "#%"pI
"d#", n
);
1381 strout (buf
, len
, len
, printcharfun
);
1389 switch (XTYPE (obj
))
1393 int len
= sprintf (buf
, "%"pI
"d", XINT (obj
));
1394 strout (buf
, len
, len
, printcharfun
);
1400 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
1401 int len
= float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1402 strout (pigbuf
, len
, len
, printcharfun
);
1408 print_string (obj
, printcharfun
);
1411 register ptrdiff_t i
, i_byte
;
1412 struct gcpro gcpro1
;
1413 ptrdiff_t size_byte
;
1414 /* 1 means we must ensure that the next character we output
1415 cannot be taken as part of a hex character escape. */
1416 bool need_nonhex
= 0;
1417 bool multibyte
= STRING_MULTIBYTE (obj
);
1421 if (! EQ (Vprint_charset_text_property
, Qt
))
1422 obj
= print_prune_string_charset (obj
);
1424 if (string_intervals (obj
))
1431 size_byte
= SBYTES (obj
);
1433 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1435 /* Here, we must convert each multi-byte form to the
1436 corresponding character code before handing it to PRINTCHAR. */
1439 FETCH_STRING_CHAR_ADVANCE (c
, obj
, i
, i_byte
);
1443 if (c
== '\n' && print_escape_newlines
)
1448 else if (c
== '\f' && print_escape_newlines
)
1454 && (CHAR_BYTE8_P (c
)
1455 || (! ASCII_CHAR_P (c
) && print_escape_multibyte
)))
1457 /* When multibyte is disabled,
1458 print multibyte string chars using hex escapes.
1459 For a char code that could be in a unibyte string,
1460 when found in a multibyte string, always use a hex escape
1461 so it reads back as multibyte. */
1465 if (CHAR_BYTE8_P (c
))
1466 len
= sprintf (outbuf
, "\\%03o", CHAR_TO_BYTE8 (c
));
1469 len
= sprintf (outbuf
, "\\x%04x", c
);
1472 strout (outbuf
, len
, len
, printcharfun
);
1474 else if (! multibyte
1475 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_CHAR_P (c
)
1476 && print_escape_nonascii
)
1478 /* When printing in a multibyte buffer
1479 or when explicitly requested,
1480 print single-byte non-ASCII string chars
1481 using octal escapes. */
1483 int len
= sprintf (outbuf
, "\\%03o", c
);
1484 strout (outbuf
, len
, len
, printcharfun
);
1488 /* If we just had a hex escape, and this character
1489 could be taken as part of it,
1490 output `\ ' to prevent that. */
1494 if ((c
>= 'a' && c
<= 'f')
1495 || (c
>= 'A' && c
<= 'F')
1496 || (c
>= '0' && c
<= '9'))
1497 strout ("\\ ", -1, -1, printcharfun
);
1500 if (c
== '\"' || c
== '\\')
1507 if (string_intervals (obj
))
1509 traverse_intervals (string_intervals (obj
),
1510 0, print_interval
, printcharfun
);
1521 unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1522 unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1524 ptrdiff_t i
, i_byte
;
1525 ptrdiff_t size_byte
;
1528 name
= SYMBOL_NAME (obj
);
1530 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1533 /* If symbol name begins with a digit, and ends with a digit,
1534 and contains nothing but digits and `e', it could be treated
1535 as a number. So set CONFUSING.
1537 Symbols that contain periods could also be taken as numbers,
1538 but periods are always escaped, so we don't have to worry
1540 else if (*p
>= '0' && *p
<= '9'
1541 && end
[-1] >= '0' && end
[-1] <= '9')
1543 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1544 /* Needed for \2e10. */
1545 || *p
== 'e' || *p
== 'E'))
1547 confusing
= (end
== p
);
1552 size_byte
= SBYTES (name
);
1554 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1559 else if (size_byte
== 0)
1566 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1568 /* Here, we must convert each multi-byte form to the
1569 corresponding character code before handing it to PRINTCHAR. */
1570 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1575 if (c
== '\"' || c
== '\\' || c
== '\''
1576 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1577 || c
== ',' || c
== '.' || c
== '`'
1578 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1580 PRINTCHAR ('\\'), confusing
= 0;
1588 /* If deeper than spec'd depth, print placeholder. */
1589 if (INTEGERP (Vprint_level
)
1590 && print_depth
> XINT (Vprint_level
))
1591 strout ("...", -1, -1, printcharfun
);
1592 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1593 && (EQ (XCAR (obj
), Qquote
)))
1596 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1598 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1599 && (EQ (XCAR (obj
), Qfunction
)))
1603 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1605 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1606 && ((EQ (XCAR (obj
), Qbackquote
))))
1608 print_object (XCAR (obj
), printcharfun
, 0);
1609 new_backquote_output
++;
1610 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1611 new_backquote_output
--;
1613 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1614 && new_backquote_output
1615 && ((EQ (XCAR (obj
), Qbackquote
)
1616 || EQ (XCAR (obj
), Qcomma
)
1617 || EQ (XCAR (obj
), Qcomma_at
)
1618 || EQ (XCAR (obj
), Qcomma_dot
))))
1620 print_object (XCAR (obj
), printcharfun
, 0);
1621 new_backquote_output
--;
1622 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1623 new_backquote_output
++;
1630 printmax_t i
, print_length
;
1631 Lisp_Object halftail
= obj
;
1633 /* Negative values of print-length are invalid in CL.
1634 Treat them like nil, as CMUCL does. */
1635 if (NATNUMP (Vprint_length
))
1636 print_length
= XFASTINT (Vprint_length
);
1638 print_length
= TYPE_MAXIMUM (printmax_t
);
1643 /* Detect circular list. */
1644 if (NILP (Vprint_circle
))
1646 /* Simple but incomplete way. */
1647 if (i
!= 0 && EQ (obj
, halftail
))
1649 int len
= sprintf (buf
, " . #%"pMd
, i
/ 2);
1650 strout (buf
, len
, len
, printcharfun
);
1656 /* With the print-circle feature. */
1659 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1662 strout (" . ", 3, 3, printcharfun
);
1663 print_object (obj
, printcharfun
, escapeflag
);
1672 if (print_length
<= i
)
1674 strout ("...", 3, 3, printcharfun
);
1679 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1683 halftail
= XCDR (halftail
);
1687 /* OBJ non-nil here means it's the end of a dotted list. */
1690 strout (" . ", 3, 3, printcharfun
);
1691 print_object (obj
, printcharfun
, escapeflag
);
1699 case Lisp_Vectorlike
:
1704 strout ("#<process ", -1, -1, printcharfun
);
1705 print_string (XPROCESS (obj
)->name
, printcharfun
);
1709 print_string (XPROCESS (obj
)->name
, printcharfun
);
1711 else if (BOOL_VECTOR_P (obj
))
1716 struct gcpro gcpro1
;
1717 EMACS_INT size
= bool_vector_size (obj
);
1718 ptrdiff_t size_in_chars
= bool_vector_bytes (size
);
1719 ptrdiff_t real_size_in_chars
= size_in_chars
;
1724 len
= sprintf (buf
, "%"pI
"d", size
);
1725 strout (buf
, len
, len
, printcharfun
);
1728 /* Don't print more characters than the specified maximum.
1729 Negative values of print-length are invalid. Treat them
1730 like a print-length of nil. */
1731 if (NATNUMP (Vprint_length
)
1732 && XFASTINT (Vprint_length
) < size_in_chars
)
1733 size_in_chars
= XFASTINT (Vprint_length
);
1735 for (i
= 0; i
< size_in_chars
; i
++)
1738 c
= bool_vector_uchar_data (obj
)[i
];
1739 if (c
== '\n' && print_escape_newlines
)
1744 else if (c
== '\f' && print_escape_newlines
)
1749 else if (c
> '\177')
1751 /* Use octal escapes to avoid encoding issues. */
1753 PRINTCHAR ('0' + ((c
>> 6) & 3));
1754 PRINTCHAR ('0' + ((c
>> 3) & 7));
1755 PRINTCHAR ('0' + (c
& 7));
1759 if (c
== '\"' || c
== '\\')
1765 if (size_in_chars
< real_size_in_chars
)
1766 strout (" ...", 4, 4, printcharfun
);
1771 else if (SUBRP (obj
))
1773 strout ("#<subr ", -1, -1, printcharfun
);
1774 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
);
1777 else if (WINDOWP (obj
))
1780 strout ("#<window ", -1, -1, printcharfun
);
1781 len
= sprintf (buf
, "%d", XWINDOW (obj
)->sequence_number
);
1782 strout (buf
, len
, len
, printcharfun
);
1783 if (BUFFERP (XWINDOW (obj
)->contents
))
1785 strout (" on ", -1, -1, printcharfun
);
1786 print_string (BVAR (XBUFFER (XWINDOW (obj
)->contents
), name
),
1791 else if (TERMINALP (obj
))
1794 struct terminal
*t
= XTERMINAL (obj
);
1795 strout ("#<terminal ", -1, -1, printcharfun
);
1796 len
= sprintf (buf
, "%d", t
->id
);
1797 strout (buf
, len
, len
, printcharfun
);
1800 strout (" on ", -1, -1, printcharfun
);
1801 strout (t
->name
, -1, -1, printcharfun
);
1805 else if (HASH_TABLE_P (obj
))
1807 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1809 ptrdiff_t real_size
, size
;
1813 strout ("#<hash-table", -1, -1, printcharfun
);
1814 if (SYMBOLP (h
->test
))
1818 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
);
1820 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
);
1822 len
= sprintf (buf
, "%"pD
"d/%"pD
"d", h
->count
, ASIZE (h
->next
));
1823 strout (buf
, len
, len
, printcharfun
);
1825 len
= sprintf (buf
, " %p>", ptr
);
1826 strout (buf
, len
, len
, printcharfun
);
1828 /* Implement a readable output, e.g.:
1829 #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
1830 /* Always print the size. */
1831 len
= sprintf (buf
, "#s(hash-table size %"pD
"d", ASIZE (h
->next
));
1832 strout (buf
, len
, len
, printcharfun
);
1834 if (!NILP (h
->test
.name
))
1836 strout (" test ", -1, -1, printcharfun
);
1837 print_object (h
->test
.name
, printcharfun
, escapeflag
);
1840 if (!NILP (h
->weak
))
1842 strout (" weakness ", -1, -1, printcharfun
);
1843 print_object (h
->weak
, printcharfun
, escapeflag
);
1846 if (!NILP (h
->rehash_size
))
1848 strout (" rehash-size ", -1, -1, printcharfun
);
1849 print_object (h
->rehash_size
, printcharfun
, escapeflag
);
1852 if (!NILP (h
->rehash_threshold
))
1854 strout (" rehash-threshold ", -1, -1, printcharfun
);
1855 print_object (h
->rehash_threshold
, printcharfun
, escapeflag
);
1858 strout (" data ", -1, -1, printcharfun
);
1860 /* Print the data here as a plist. */
1861 real_size
= HASH_TABLE_SIZE (h
);
1864 /* Don't print more elements than the specified maximum. */
1865 if (NATNUMP (Vprint_length
)
1866 && XFASTINT (Vprint_length
) < size
)
1867 size
= XFASTINT (Vprint_length
);
1870 for (i
= 0; i
< size
; i
++)
1871 if (!NILP (HASH_HASH (h
, i
)))
1873 if (i
) PRINTCHAR (' ');
1874 print_object (HASH_KEY (h
, i
), printcharfun
, escapeflag
);
1876 print_object (HASH_VALUE (h
, i
), printcharfun
, escapeflag
);
1879 if (size
< real_size
)
1880 strout (" ...", 4, 4, printcharfun
);
1886 else if (BUFFERP (obj
))
1888 if (!BUFFER_LIVE_P (XBUFFER (obj
)))
1889 strout ("#<killed buffer>", -1, -1, printcharfun
);
1890 else if (escapeflag
)
1892 strout ("#<buffer ", -1, -1, printcharfun
);
1893 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1897 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1899 else if (WINDOW_CONFIGURATIONP (obj
))
1901 strout ("#<window-configuration>", -1, -1, printcharfun
);
1903 else if (FRAMEP (obj
))
1906 void *ptr
= XFRAME (obj
);
1907 Lisp_Object frame_name
= XFRAME (obj
)->name
;
1909 strout ((FRAME_LIVE_P (XFRAME (obj
))
1910 ? "#<frame " : "#<dead frame "),
1911 -1, -1, printcharfun
);
1912 if (!STRINGP (frame_name
))
1914 /* A frame could be too young and have no name yet;
1916 if (SYMBOLP (frame_name
))
1917 frame_name
= Fsymbol_name (frame_name
);
1918 else /* can't happen: name should be either nil or string */
1919 frame_name
= build_string ("*INVALID*FRAME*NAME*");
1921 print_string (frame_name
, printcharfun
);
1922 len
= sprintf (buf
, " %p>", ptr
);
1923 strout (buf
, len
, len
, printcharfun
);
1925 else if (FONTP (obj
))
1929 if (! FONT_OBJECT_P (obj
))
1931 if (FONT_SPEC_P (obj
))
1932 strout ("#<font-spec", -1, -1, printcharfun
);
1934 strout ("#<font-entity", -1, -1, printcharfun
);
1935 for (i
= 0; i
< FONT_SPEC_MAX
; i
++)
1938 if (i
< FONT_WEIGHT_INDEX
|| i
> FONT_WIDTH_INDEX
)
1939 print_object (AREF (obj
, i
), printcharfun
, escapeflag
);
1941 print_object (font_style_symbolic (obj
, i
, 0),
1942 printcharfun
, escapeflag
);
1947 strout ("#<font-object ", -1, -1, printcharfun
);
1948 print_object (AREF (obj
, FONT_NAME_INDEX
), printcharfun
,
1955 ptrdiff_t size
= ASIZE (obj
);
1956 if (COMPILEDP (obj
))
1959 size
&= PSEUDOVECTOR_SIZE_MASK
;
1961 if (CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
))
1963 /* We print a char-table as if it were a vector,
1964 lumping the parent and default slots in with the
1965 character slots. But we add #^ as a prefix. */
1967 /* Make each lowest sub_char_table start a new line.
1968 Otherwise we'll make a line extremely long, which
1969 results in slow redisplay. */
1970 if (SUB_CHAR_TABLE_P (obj
)
1971 && XSUB_CHAR_TABLE (obj
)->depth
== 3)
1975 if (SUB_CHAR_TABLE_P (obj
))
1977 size
&= PSEUDOVECTOR_SIZE_MASK
;
1979 if (size
& PSEUDOVECTOR_FLAG
)
1984 int i
, idx
= SUB_CHAR_TABLE_P (obj
) ? SUB_CHAR_TABLE_OFFSET
: 0;
1985 register Lisp_Object tem
;
1986 ptrdiff_t real_size
= size
;
1988 /* For a sub char-table, print heading non-Lisp data first. */
1989 if (SUB_CHAR_TABLE_P (obj
))
1991 i
= sprintf (buf
, "%d %d", XSUB_CHAR_TABLE (obj
)->depth
,
1992 XSUB_CHAR_TABLE (obj
)->min_char
);
1993 strout (buf
, i
, i
, printcharfun
);
1996 /* Don't print more elements than the specified maximum. */
1997 if (NATNUMP (Vprint_length
)
1998 && XFASTINT (Vprint_length
) < size
)
1999 size
= XFASTINT (Vprint_length
);
2001 for (i
= idx
; i
< size
; i
++)
2003 if (i
) PRINTCHAR (' ');
2004 tem
= AREF (obj
, i
);
2005 print_object (tem
, printcharfun
, escapeflag
);
2007 if (size
< real_size
)
2008 strout (" ...", 4, 4, printcharfun
);
2015 switch (XMISCTYPE (obj
))
2017 case Lisp_Misc_Marker
:
2018 strout ("#<marker ", -1, -1, printcharfun
);
2019 /* Do you think this is necessary? */
2020 if (XMARKER (obj
)->insertion_type
!= 0)
2021 strout ("(moves after insertion) ", -1, -1, printcharfun
);
2022 if (! XMARKER (obj
)->buffer
)
2023 strout ("in no buffer", -1, -1, printcharfun
);
2026 int len
= sprintf (buf
, "at %"pD
"d", marker_position (obj
));
2027 strout (buf
, len
, len
, printcharfun
);
2028 strout (" in ", -1, -1, printcharfun
);
2029 print_string (BVAR (XMARKER (obj
)->buffer
, name
), printcharfun
);
2034 case Lisp_Misc_Overlay
:
2035 strout ("#<overlay ", -1, -1, printcharfun
);
2036 if (! XMARKER (OVERLAY_START (obj
))->buffer
)
2037 strout ("in no buffer", -1, -1, printcharfun
);
2040 int len
= sprintf (buf
, "from %"pD
"d to %"pD
"d in ",
2041 marker_position (OVERLAY_START (obj
)),
2042 marker_position (OVERLAY_END (obj
)));
2043 strout (buf
, len
, len
, printcharfun
);
2044 print_string (BVAR (XMARKER (OVERLAY_START (obj
))->buffer
, name
),
2050 /* Remaining cases shouldn't happen in normal usage, but let's
2051 print them anyway for the benefit of the debugger. */
2053 case Lisp_Misc_Free
:
2054 strout ("#<misc free cell>", -1, -1, printcharfun
);
2057 case Lisp_Misc_Save_Value
:
2060 struct Lisp_Save_Value
*v
= XSAVE_VALUE (obj
);
2062 strout ("#<save-value ", -1, -1, printcharfun
);
2064 if (v
->save_type
== SAVE_TYPE_MEMORY
)
2066 ptrdiff_t amount
= v
->data
[1].integer
;
2070 /* valid_lisp_object_p is reliable, so try to print up
2071 to 8 saved objects. This code is rarely used, so
2072 it's OK that valid_lisp_object_p is slow. */
2074 int limit
= min (amount
, 8);
2075 Lisp_Object
*area
= v
->data
[0].pointer
;
2077 i
= sprintf (buf
, "with %"pD
"d objects", amount
);
2078 strout (buf
, i
, i
, printcharfun
);
2080 for (i
= 0; i
< limit
; i
++)
2082 Lisp_Object maybe
= area
[i
];
2084 if (valid_lisp_object_p (maybe
) > 0)
2087 print_object (maybe
, printcharfun
, escapeflag
);
2090 strout (" <invalid>", -1, -1, printcharfun
);
2092 if (i
== limit
&& i
< amount
)
2093 strout (" ...", 4, 4, printcharfun
);
2095 #else /* not GC_MARK_STACK */
2097 /* There is no reliable way to determine whether the objects
2098 are initialized, so do not try to print them. */
2100 i
= sprintf (buf
, "with %"pD
"d objects", amount
);
2101 strout (buf
, i
, i
, printcharfun
);
2103 #endif /* GC_MARK_STACK */
2107 /* Print each slot according to its type. */
2109 for (index
= 0; index
< SAVE_VALUE_SLOTS
; index
++)
2114 switch (save_type (v
, index
))
2117 i
= sprintf (buf
, "<unused>");
2121 i
= sprintf (buf
, "<pointer %p>",
2122 v
->data
[index
].pointer
);
2125 case SAVE_FUNCPOINTER
:
2126 i
= sprintf (buf
, "<funcpointer %p>",
2127 ((void *) (intptr_t)
2128 v
->data
[index
].funcpointer
));
2132 i
= sprintf (buf
, "<integer %"pD
"d>",
2133 v
->data
[index
].integer
);
2137 print_object (v
->data
[index
].object
, printcharfun
,
2145 strout (buf
, i
, i
, printcharfun
);
2161 /* We're in trouble if this happens!
2162 Probably should just emacs_abort (). */
2163 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
);
2165 len
= sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2166 else if (VECTORLIKEP (obj
))
2167 len
= sprintf (buf
, "(PVEC 0x%08"pD
"x)", ASIZE (obj
));
2169 len
= sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2170 strout (buf
, len
, len
, printcharfun
);
2171 strout (" Save your buffers immediately and please report this bug>",
2172 -1, -1, printcharfun
);
2180 /* Print a description of INTERVAL using PRINTCHARFUN.
2181 This is part of printing a string that has text properties. */
2184 print_interval (INTERVAL interval
, Lisp_Object printcharfun
)
2186 if (NILP (interval
->plist
))
2189 print_object (make_number (interval
->position
), printcharfun
, 1);
2191 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2194 print_object (interval
->plist
, printcharfun
, 1);
2197 /* Initialize debug_print stuff early to have it working from the very
2201 init_print_once (void)
2203 DEFSYM (Qexternal_debugging_output
, "external-debugging-output");
2204 defsubr (&Sexternal_debugging_output
);
2208 syms_of_print (void)
2210 DEFSYM (Qtemp_buffer_setup_hook
, "temp-buffer-setup-hook");
2212 DEFVAR_LISP ("standard-output", Vstandard_output
,
2213 doc
: /* Output stream `print' uses by default for outputting a character.
2214 This may be any function of one argument.
2215 It may also be a buffer (output is inserted before point)
2216 or a marker (output is inserted and the marker is advanced)
2217 or the symbol t (output appears in the echo area). */);
2218 Vstandard_output
= Qt
;
2219 DEFSYM (Qstandard_output
, "standard-output");
2221 DEFVAR_LISP ("float-output-format", Vfloat_output_format
,
2222 doc
: /* The format descriptor string used to print floats.
2223 This is a %-spec like those accepted by `printf' in C,
2224 but with some restrictions. It must start with the two characters `%.'.
2225 After that comes an integer precision specification,
2226 and then a letter which controls the format.
2227 The letters allowed are `e', `f' and `g'.
2228 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2229 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2230 Use `g' to choose the shorter of those two formats for the number at hand.
2231 The precision in any of these cases is the number of digits following
2232 the decimal point. With `f', a precision of 0 means to omit the
2233 decimal point. 0 is not allowed with `e' or `g'.
2235 A value of nil means to use the shortest notation
2236 that represents the number without losing information. */);
2237 Vfloat_output_format
= Qnil
;
2238 DEFSYM (Qfloat_output_format
, "float-output-format");
2240 DEFVAR_LISP ("print-length", Vprint_length
,
2241 doc
: /* Maximum length of list to print before abbreviating.
2242 A value of nil means no limit. See also `eval-expression-print-length'. */);
2243 Vprint_length
= Qnil
;
2245 DEFVAR_LISP ("print-level", Vprint_level
,
2246 doc
: /* Maximum depth of list nesting to print before abbreviating.
2247 A value of nil means no limit. See also `eval-expression-print-level'. */);
2248 Vprint_level
= Qnil
;
2250 DEFVAR_BOOL ("print-escape-newlines", print_escape_newlines
,
2251 doc
: /* Non-nil means print newlines in strings as `\\n'.
2252 Also print formfeeds as `\\f'. */);
2253 print_escape_newlines
= 0;
2255 DEFVAR_BOOL ("print-escape-nonascii", print_escape_nonascii
,
2256 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2257 \(OOO is the octal representation of the character code.)
2258 Only single-byte characters are affected, and only in `prin1'.
2259 When the output goes in a multibyte buffer, this feature is
2260 enabled regardless of the value of the variable. */);
2261 print_escape_nonascii
= 0;
2263 DEFVAR_BOOL ("print-escape-multibyte", print_escape_multibyte
,
2264 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2265 \(XXXX is the hex representation of the character code.)
2266 This affects only `prin1'. */);
2267 print_escape_multibyte
= 0;
2269 DEFVAR_BOOL ("print-quoted", print_quoted
,
2270 doc
: /* Non-nil means print quoted forms with reader syntax.
2271 I.e., (quote foo) prints as 'foo, (function foo) as #'foo. */);
2274 DEFVAR_LISP ("print-gensym", Vprint_gensym
,
2275 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2276 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2277 When the uninterned symbol appears within a recursive data structure,
2278 and the symbol appears more than once, in addition use the #N# and #N=
2279 constructs as needed, so that multiple references to the same symbol are
2280 shared once again when the text is read back. */);
2281 Vprint_gensym
= Qnil
;
2283 DEFVAR_LISP ("print-circle", Vprint_circle
,
2284 doc
: /* Non-nil means print recursive structures using #N= and #N# syntax.
2285 If nil, printing proceeds recursively and may lead to
2286 `max-lisp-eval-depth' being exceeded or an error may occur:
2287 \"Apparently circular structure being printed.\" Also see
2288 `print-length' and `print-level'.
2289 If non-nil, shared substructures anywhere in the structure are printed
2290 with `#N=' before the first occurrence (in the order of the print
2291 representation) and `#N#' in place of each subsequent occurrence,
2292 where N is a positive decimal integer. */);
2293 Vprint_circle
= Qnil
;
2295 DEFVAR_LISP ("print-continuous-numbering", Vprint_continuous_numbering
,
2296 doc
: /* Non-nil means number continuously across print calls.
2297 This affects the numbers printed for #N= labels and #M# references.
2298 See also `print-circle', `print-gensym', and `print-number-table'.
2299 This variable should not be set with `setq'; bind it with a `let' instead. */);
2300 Vprint_continuous_numbering
= Qnil
;
2302 DEFVAR_LISP ("print-number-table", Vprint_number_table
,
2303 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2304 The Lisp printer uses this vector to detect Lisp objects referenced more
2307 When you bind `print-continuous-numbering' to t, you should probably
2308 also bind `print-number-table' to nil. This ensures that the value of
2309 `print-number-table' can be garbage-collected once the printing is
2310 done. If all elements of `print-number-table' are nil, it means that
2311 the printing done so far has not found any shared structure or objects
2312 that need to be recorded in the table. */);
2313 Vprint_number_table
= Qnil
;
2315 DEFVAR_LISP ("print-charset-text-property", Vprint_charset_text_property
,
2316 doc
: /* A flag to control printing of `charset' text property on printing a string.
2317 The value must be nil, t, or `default'.
2319 If the value is nil, don't print the text property `charset'.
2321 If the value is t, always print the text property `charset'.
2323 If the value is `default', print the text property `charset' only when
2324 the value is different from what is guessed in the current charset
2326 Vprint_charset_text_property
= Qdefault
;
2328 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2329 staticpro (&Vprin1_to_string_buffer
);
2332 defsubr (&Sprin1_to_string
);
2333 defsubr (&Serror_message_string
);
2337 defsubr (&Swrite_char
);
2338 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2339 defsubr (&Sredirect_debugging_output
);
2342 DEFSYM (Qprint_escape_newlines
, "print-escape-newlines");
2343 DEFSYM (Qprint_escape_multibyte
, "print-escape-multibyte");
2344 DEFSYM (Qprint_escape_nonascii
, "print-escape-nonascii");
2346 print_prune_charset_plist
= Qnil
;
2347 staticpro (&print_prune_charset_plist
);