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_atomic (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)))\
172 unsigned char *temp = alloca (print_buffer_pos + 1); \
173 copy_text ((unsigned char *) print_buffer, temp, \
174 print_buffer_pos_byte, 1, 0); \
175 insert_1_both ((char *) temp, print_buffer_pos, \
176 print_buffer_pos, 0, 1, 0); \
179 insert_1_both (print_buffer, print_buffer_pos, \
180 print_buffer_pos_byte, 0, 1, 0); \
181 signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
183 if (free_print_buffer) \
185 xfree (print_buffer); \
188 unbind_to (specpdl_count, Qnil); \
189 if (MARKERP (original)) \
190 set_marker_both (original, Qnil, PT, PT_BYTE); \
191 if (old_point >= 0) \
192 SET_PT_BOTH (old_point + (old_point >= start_point \
193 ? PT - start_point : 0), \
194 old_point_byte + (old_point_byte >= start_point_byte \
195 ? PT_BYTE - start_point_byte : 0)); \
196 set_buffer_internal (old);
198 #define PRINTCHAR(ch) printchar (ch, printcharfun)
200 /* This is used to restore the saved contents of print_buffer
201 when there is a recursive call to print. */
204 print_unwind (Lisp_Object saved_text
)
206 memcpy (print_buffer
, SDATA (saved_text
), SCHARS (saved_text
));
210 /* Print character CH using method FUN. FUN nil means print to
211 print_buffer. FUN t means print to echo area or stdout if
212 non-interactive. If FUN is neither nil nor t, call FUN with CH as
216 printchar (unsigned int ch
, Lisp_Object fun
)
218 if (!NILP (fun
) && !EQ (fun
, Qt
))
219 call1 (fun
, make_number (ch
));
222 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
223 int len
= CHAR_STRING (ch
, str
);
229 ptrdiff_t incr
= len
- (print_buffer_size
- print_buffer_pos_byte
);
231 print_buffer
= xpalloc (print_buffer
, &print_buffer_size
,
233 memcpy (print_buffer
+ print_buffer_pos_byte
, str
, len
);
234 print_buffer_pos
+= 1;
235 print_buffer_pos_byte
+= len
;
237 else if (noninteractive
)
239 fwrite (str
, 1, len
, stdout
);
240 noninteractive_need_newline
= 1;
245 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
247 setup_echo_area_for_printing (multibyte_p
);
249 message_dolog ((char *) str
, len
, 0, multibyte_p
);
255 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
256 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
257 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
258 print_buffer. PRINTCHARFUN t means output to the echo area or to
259 stdout if non-interactive. If neither nil nor t, call Lisp
260 function PRINTCHARFUN for each character printed. MULTIBYTE
261 non-zero means PTR contains multibyte characters.
263 In the case where PRINTCHARFUN is nil, it is safe for PTR to point
264 to data in a Lisp string. Otherwise that is not safe. */
267 strout (const char *ptr
, ptrdiff_t size
, ptrdiff_t size_byte
,
268 Lisp_Object printcharfun
)
271 size_byte
= size
= strlen (ptr
);
273 if (NILP (printcharfun
))
275 ptrdiff_t incr
= size_byte
- (print_buffer_size
- print_buffer_pos_byte
);
277 print_buffer
= xpalloc (print_buffer
, &print_buffer_size
, incr
, -1, 1);
278 memcpy (print_buffer
+ print_buffer_pos_byte
, ptr
, size_byte
);
279 print_buffer_pos
+= size
;
280 print_buffer_pos_byte
+= size_byte
;
282 else if (noninteractive
&& EQ (printcharfun
, Qt
))
284 fwrite (ptr
, 1, size_byte
, stdout
);
285 noninteractive_need_newline
= 1;
287 else if (EQ (printcharfun
, Qt
))
289 /* Output to echo area. We're trying to avoid a little overhead
290 here, that's the reason we don't call printchar to do the
294 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
296 setup_echo_area_for_printing (multibyte_p
);
297 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
299 if (size
== size_byte
)
301 for (i
= 0; i
< size
; ++i
)
302 insert_char ((unsigned char) *ptr
++);
307 for (i
= 0; i
< size_byte
; i
+= len
)
309 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
317 /* PRINTCHARFUN is a Lisp function. */
320 if (size
== size_byte
)
322 while (i
< size_byte
)
330 while (i
< size_byte
)
332 /* Here, we must convert each multi-byte form to the
333 corresponding character code before handing it to
336 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
345 /* Print the contents of a string STRING using PRINTCHARFUN.
346 It isn't safe to use strout in many cases,
347 because printing one char can relocate. */
350 print_string (Lisp_Object string
, Lisp_Object printcharfun
)
352 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
356 if (print_escape_nonascii
)
357 string
= string_escape_byte8 (string
);
359 if (STRING_MULTIBYTE (string
))
360 chars
= SCHARS (string
);
361 else if (! print_escape_nonascii
362 && (EQ (printcharfun
, Qt
)
363 ? ! NILP (BVAR (&buffer_defaults
, enable_multibyte_characters
))
364 : ! NILP (BVAR (current_buffer
, enable_multibyte_characters
))))
366 /* If unibyte string STRING contains 8-bit codes, we must
367 convert STRING to a multibyte string containing the same
372 chars
= SBYTES (string
);
373 bytes
= count_size_as_multibyte (SDATA (string
), chars
);
376 newstr
= make_uninit_multibyte_string (chars
, bytes
);
377 memcpy (SDATA (newstr
), SDATA (string
), chars
);
378 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
383 chars
= SBYTES (string
);
385 if (EQ (printcharfun
, Qt
))
387 /* Output to echo area. */
388 ptrdiff_t nbytes
= SBYTES (string
);
390 /* Copy the string contents so that relocation of STRING by
391 GC does not cause trouble. */
393 char *buffer
= SAFE_ALLOCA (nbytes
);
394 memcpy (buffer
, SDATA (string
), nbytes
);
396 strout (buffer
, chars
, nbytes
, printcharfun
);
401 /* No need to copy, since output to print_buffer can't GC. */
402 strout (SSDATA (string
), chars
, SBYTES (string
), printcharfun
);
406 /* Otherwise, string may be relocated by printing one char.
407 So re-fetch the string address for each character. */
409 ptrdiff_t size
= SCHARS (string
);
410 ptrdiff_t size_byte
= SBYTES (string
);
413 if (size
== size_byte
)
414 for (i
= 0; i
< size
; i
++)
415 PRINTCHAR (SREF (string
, i
));
417 for (i
= 0; i
< size_byte
; )
419 /* Here, we must convert each multi-byte form to the
420 corresponding character code before handing it to PRINTCHAR. */
422 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
, len
);
430 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
431 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
432 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
433 (Lisp_Object character
, Lisp_Object printcharfun
)
437 if (NILP (printcharfun
))
438 printcharfun
= Vstandard_output
;
439 CHECK_NUMBER (character
);
441 PRINTCHAR (XINT (character
));
446 /* Used from outside of print.c to print a block of SIZE
447 single-byte chars at DATA on the default output stream.
448 Do not use this on the contents of a Lisp string. */
451 write_string (const char *data
, int size
)
454 Lisp_Object printcharfun
;
456 printcharfun
= Vstandard_output
;
459 strout (data
, size
, size
, printcharfun
);
463 /* Used to print a block of SIZE single-byte chars at DATA on a
464 specified stream PRINTCHARFUN.
465 Do not use this on the contents of a Lisp string. */
468 write_string_1 (const char *data
, int size
, Lisp_Object printcharfun
)
473 strout (data
, size
, size
, printcharfun
);
479 temp_output_buffer_setup (const char *bufname
)
481 ptrdiff_t count
= SPECPDL_INDEX ();
482 register struct buffer
*old
= current_buffer
;
483 register Lisp_Object buf
;
485 record_unwind_current_buffer ();
487 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
489 Fkill_all_local_variables ();
490 delete_all_overlays (current_buffer
);
491 bset_directory (current_buffer
, BVAR (old
, directory
));
492 bset_read_only (current_buffer
, Qnil
);
493 bset_filename (current_buffer
, Qnil
);
494 bset_undo_list (current_buffer
, Qt
);
495 eassert (current_buffer
->overlays_before
== NULL
);
496 eassert (current_buffer
->overlays_after
== NULL
);
497 bset_enable_multibyte_characters
498 (current_buffer
, BVAR (&buffer_defaults
, enable_multibyte_characters
));
499 specbind (Qinhibit_read_only
, Qt
);
500 specbind (Qinhibit_modification_hooks
, Qt
);
502 XSETBUFFER (buf
, current_buffer
);
504 Frun_hooks (1, &Qtemp_buffer_setup_hook
);
506 unbind_to (count
, Qnil
);
508 specbind (Qstandard_output
, buf
);
511 static void print (Lisp_Object
, Lisp_Object
, bool);
512 static void print_preprocess (Lisp_Object
);
513 static void print_preprocess_string (INTERVAL
, Lisp_Object
);
514 static void print_object (Lisp_Object
, Lisp_Object
, bool);
516 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
517 doc
: /* Output a newline to stream PRINTCHARFUN.
518 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
519 (Lisp_Object printcharfun
)
523 if (NILP (printcharfun
))
524 printcharfun
= Vstandard_output
;
531 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
532 doc
: /* Output the printed representation of OBJECT, any Lisp object.
533 Quoting characters are printed when needed to make output that `read'
534 can handle, whenever this is possible. For complex objects, the behavior
535 is controlled by `print-level' and `print-length', which see.
537 OBJECT is any of the Lisp data types: a number, a string, a symbol,
538 a list, a buffer, a window, a frame, etc.
540 A printed representation of an object is text which describes that object.
542 Optional argument PRINTCHARFUN is the output stream, which can be one
545 - a buffer, in which case output is inserted into that buffer at point;
546 - a marker, in which case output is inserted at marker's position;
547 - a function, in which case that function is called once for each
548 character of OBJECT's printed representation;
549 - a symbol, in which case that symbol's function definition is called; or
550 - t, in which case the output is displayed in the echo area.
552 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
554 (Lisp_Object object
, Lisp_Object printcharfun
)
558 if (NILP (printcharfun
))
559 printcharfun
= Vstandard_output
;
561 print (object
, printcharfun
, 1);
566 /* a buffer which is used to hold output being built by prin1-to-string */
567 Lisp_Object Vprin1_to_string_buffer
;
569 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
570 doc
: /* Return a string containing the printed representation of OBJECT.
571 OBJECT can be any Lisp object. This function outputs quoting characters
572 when necessary to make output that `read' can handle, whenever possible,
573 unless the optional second argument NOESCAPE is non-nil. For complex objects,
574 the behavior is controlled by `print-level' and `print-length', which see.
576 OBJECT is any of the Lisp data types: a number, a string, a symbol,
577 a list, a buffer, a window, a frame, etc.
579 A printed representation of an object is text which describes that object. */)
580 (Lisp_Object object
, Lisp_Object noescape
)
582 Lisp_Object printcharfun
;
583 bool prev_abort_on_gc
;
584 /* struct gcpro gcpro1, gcpro2; */
585 Lisp_Object save_deactivate_mark
;
586 ptrdiff_t count
= SPECPDL_INDEX ();
587 struct buffer
*previous
;
589 specbind (Qinhibit_modification_hooks
, Qt
);
594 /* Save and restore this--we are altering a buffer
595 but we don't want to deactivate the mark just for that.
596 No need for specbind, since errors deactivate the mark. */
597 save_deactivate_mark
= Vdeactivate_mark
;
598 /* GCPRO2 (object, save_deactivate_mark); */
600 printcharfun
= Vprin1_to_string_buffer
;
602 print (object
, printcharfun
, NILP (noescape
));
603 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINISH */
607 previous
= current_buffer
;
608 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
609 object
= Fbuffer_string ();
610 if (SBYTES (object
) == SCHARS (object
))
611 STRING_SET_UNIBYTE (object
);
613 /* Note that this won't make prepare_to_modify_buffer call
614 ask-user-about-supersession-threat because this buffer
615 does not visit a file. */
617 set_buffer_internal (previous
);
619 Vdeactivate_mark
= save_deactivate_mark
;
622 return unbind_to (count
, object
);
625 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
626 doc
: /* Output the printed representation of OBJECT, any Lisp object.
627 No quoting characters are used; no delimiters are printed around
628 the contents of strings.
630 OBJECT is any of the Lisp data types: a number, a string, a symbol,
631 a list, a buffer, a window, a frame, etc.
633 A printed representation of an object is text which describes that object.
635 Optional argument PRINTCHARFUN is the output stream, which can be one
638 - a buffer, in which case output is inserted into that buffer at point;
639 - a marker, in which case output is inserted at marker's position;
640 - a function, in which case that function is called once for each
641 character of OBJECT's printed representation;
642 - a symbol, in which case that symbol's function definition is called; or
643 - t, in which case the output is displayed in the echo area.
645 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
647 (Lisp_Object object
, Lisp_Object printcharfun
)
651 if (NILP (printcharfun
))
652 printcharfun
= Vstandard_output
;
654 print (object
, printcharfun
, 0);
659 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
660 doc
: /* Output the printed representation of OBJECT, with newlines around it.
661 Quoting characters are printed when needed to make output that `read'
662 can handle, whenever this is possible. For complex objects, the behavior
663 is controlled by `print-level' and `print-length', which see.
665 OBJECT is any of the Lisp data types: a number, a string, a symbol,
666 a list, a buffer, a window, a frame, etc.
668 A printed representation of an object is text which describes that object.
670 Optional argument PRINTCHARFUN is the output stream, which can be one
673 - a buffer, in which case output is inserted into that buffer at point;
674 - a marker, in which case output is inserted at marker's position;
675 - a function, in which case that function is called once for each
676 character of OBJECT's printed representation;
677 - a symbol, in which case that symbol's function definition is called; or
678 - t, in which case the output is displayed in the echo area.
680 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
682 (Lisp_Object object
, Lisp_Object printcharfun
)
687 if (NILP (printcharfun
))
688 printcharfun
= Vstandard_output
;
692 print (object
, printcharfun
, 1);
699 /* The subroutine object for external-debugging-output is kept here
700 for the convenience of the debugger. */
701 Lisp_Object Qexternal_debugging_output
;
703 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
704 doc
: /* Write CHARACTER to stderr.
705 You can call print while debugging emacs, and pass it this function
706 to make it write to the debugging output. */)
707 (Lisp_Object character
)
711 CHECK_NUMBER (character
);
712 ch
= XINT (character
);
713 if (ASCII_CHAR_P (ch
))
717 /* Send the output to a debugger (nothing happens if there isn't
719 if (print_output_debug_flag
)
721 char buf
[2] = {(char) XINT (character
), '\0'};
722 OutputDebugString (buf
);
728 unsigned char mbstr
[MAX_MULTIBYTE_LENGTH
];
729 ptrdiff_t len
= CHAR_STRING (ch
, mbstr
);
730 Lisp_Object encoded_ch
=
731 ENCODE_SYSTEM (make_multibyte_string ((char *) mbstr
, 1, len
));
733 fwrite (SSDATA (encoded_ch
), SBYTES (encoded_ch
), 1, stderr
);
735 if (print_output_debug_flag
)
736 OutputDebugString (SSDATA (encoded_ch
));
743 /* This function is never called. Its purpose is to prevent
744 print_output_debug_flag from being optimized away. */
746 extern void debug_output_compilation_hack (bool) EXTERNALLY_VISIBLE
;
748 debug_output_compilation_hack (bool x
)
750 print_output_debug_flag
= x
;
753 #if defined (GNU_LINUX)
755 /* This functionality is not vitally important in general, so we rely on
756 non-portable ability to use stderr as lvalue. */
758 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
760 static FILE *initial_stderr_stream
= NULL
;
762 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
764 "FDebug output file: \nP",
765 doc
: /* Redirect debugging output (stderr stream) to file FILE.
766 If FILE is nil, reset target to the initial stderr stream.
767 Optional arg APPEND non-nil (interactively, with prefix arg) means
768 append to existing target file. */)
769 (Lisp_Object file
, Lisp_Object append
)
771 if (initial_stderr_stream
!= NULL
)
777 stderr
= initial_stderr_stream
;
778 initial_stderr_stream
= NULL
;
782 file
= Fexpand_file_name (file
, Qnil
);
783 initial_stderr_stream
= stderr
;
784 stderr
= emacs_fopen (SSDATA (file
), NILP (append
) ? "w" : "a");
787 stderr
= initial_stderr_stream
;
788 initial_stderr_stream
= NULL
;
789 report_file_error ("Cannot open debugging output stream", file
);
794 #endif /* GNU_LINUX */
797 /* This is the interface for debugging printing. */
800 debug_print (Lisp_Object arg
)
802 Fprin1 (arg
, Qexternal_debugging_output
);
803 fprintf (stderr
, "\r\n");
806 void safe_debug_print (Lisp_Object
) EXTERNALLY_VISIBLE
;
808 safe_debug_print (Lisp_Object arg
)
810 int valid
= valid_lisp_object_p (arg
);
815 fprintf (stderr
, "#<%s_LISP_OBJECT 0x%08"pI
"x>\r\n",
816 !valid
? "INVALID" : "SOME",
821 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
823 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
824 See Info anchor `(elisp)Definition of signal' for some details on how this
825 error message is constructed. */)
828 struct buffer
*old
= current_buffer
;
832 /* If OBJ is (error STRING), just return STRING.
833 That is not only faster, it also avoids the need to allocate
834 space here when the error is due to memory full. */
835 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
836 && CONSP (XCDR (obj
))
837 && STRINGP (XCAR (XCDR (obj
)))
838 && NILP (XCDR (XCDR (obj
))))
839 return XCAR (XCDR (obj
));
841 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
843 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
844 value
= Fbuffer_string ();
848 set_buffer_internal (old
);
854 /* Print an error message for the error DATA onto Lisp output stream
855 STREAM (suitable for the print functions).
856 CONTEXT is a C string describing the context of the error.
857 CALLER is the Lisp function inside which the error was signaled. */
860 print_error_message (Lisp_Object data
, Lisp_Object stream
, const char *context
,
863 Lisp_Object errname
, errmsg
, file_error
, tail
;
867 write_string_1 (context
, -1, stream
);
869 /* If we know from where the error was signaled, show it in
871 if (!NILP (caller
) && SYMBOLP (caller
))
873 Lisp_Object cname
= SYMBOL_NAME (caller
);
874 ptrdiff_t cnamelen
= SBYTES (cname
);
876 char *name
= SAFE_ALLOCA (cnamelen
);
877 memcpy (name
, SDATA (cname
), cnamelen
);
878 message_dolog (name
, cnamelen
, 0, 0);
879 message_dolog (": ", 2, 0, 0);
883 errname
= Fcar (data
);
885 if (EQ (errname
, Qerror
))
890 errmsg
= Fcar (data
);
895 Lisp_Object error_conditions
= Fget (errname
, Qerror_conditions
);
896 errmsg
= Fget (errname
, Qerror_message
);
897 file_error
= Fmemq (Qfile_error
, error_conditions
);
900 /* Print an error message including the data items. */
902 tail
= Fcdr_safe (data
);
905 /* For file-error, make error message by concatenating
906 all the data items. They are all strings. */
907 if (!NILP (file_error
) && CONSP (tail
))
908 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
911 const char *sep
= ": ";
913 if (!STRINGP (errmsg
))
914 write_string_1 ("peculiar error", -1, stream
);
915 else if (SCHARS (errmsg
))
916 Fprinc (errmsg
, stream
);
920 for (; CONSP (tail
); tail
= XCDR (tail
), sep
= ", ")
925 write_string_1 (sep
, 2, stream
);
927 if (!NILP (file_error
)
928 || EQ (errname
, Qend_of_file
) || EQ (errname
, Quser_error
))
929 Fprinc (obj
, stream
);
931 Fprin1 (obj
, stream
);
941 * The buffer should be at least as large as the max string size of the
942 * largest float, printed in the biggest notation. This is undoubtedly
943 * 20d float_output_format, with the negative of the C-constant "HUGE"
946 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
948 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
949 * case of -1e307 in 20d float_output_format. What is one to do (short of
950 * re-writing _doprnt to be more sane)?
952 * Given the above, the buffer must be least FLOAT_TO_STRING_BUFSIZE bytes.
956 float_to_string (char *buf
, double data
)
962 /* Check for plus infinity in a way that won't lose
963 if there is no plus infinity. */
964 if (data
== data
/ 2 && data
> 1.0)
966 static char const infinity_string
[] = "1.0e+INF";
967 strcpy (buf
, infinity_string
);
968 return sizeof infinity_string
- 1;
970 /* Likewise for minus infinity. */
971 if (data
== data
/ 2 && data
< -1.0)
973 static char const minus_infinity_string
[] = "-1.0e+INF";
974 strcpy (buf
, minus_infinity_string
);
975 return sizeof minus_infinity_string
- 1;
977 /* Check for NaN in a way that won't fail if there are no NaNs. */
978 if (! (data
* 0.0 >= 0.0))
980 /* Prepend "-" if the NaN's sign bit is negative.
981 The sign bit of a double is the bit that is 1 in -0.0. */
982 static char const NaN_string
[] = "0.0e+NaN";
984 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
987 u_minus_zero
.d
= - 0.0;
988 for (i
= 0; i
< sizeof (double); i
++)
989 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
996 strcpy (buf
+ negative
, NaN_string
);
997 return negative
+ sizeof NaN_string
- 1;
1000 if (NILP (Vfloat_output_format
)
1001 || !STRINGP (Vfloat_output_format
))
1004 /* Generate the fewest number of digits that represent the
1005 floating point value without losing information. */
1006 len
= dtoastr (buf
, FLOAT_TO_STRING_BUFSIZE
- 2, 0, 0, data
);
1007 /* The decimal point must be printed, or the byte compiler can
1008 get confused (Bug#8033). */
1011 else /* oink oink */
1013 /* Check that the spec we have is fully valid.
1014 This means not only valid for printf,
1015 but meant for floats, and reasonable. */
1016 cp
= SSDATA (Vfloat_output_format
);
1025 /* Check the width specification. */
1027 if ('0' <= *cp
&& *cp
<= '9')
1032 width
= (width
* 10) + (*cp
++ - '0');
1033 if (DBL_DIG
< width
)
1036 while (*cp
>= '0' && *cp
<= '9');
1038 /* A precision of zero is valid only for %f. */
1039 if (width
== 0 && *cp
!= 'f')
1043 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1049 len
= sprintf (buf
, SSDATA (Vfloat_output_format
), data
);
1052 /* Make sure there is a decimal point with digit after, or an
1053 exponent, so that the value is readable as a float. But don't do
1054 this with "%.0f"; it's valid for that not to produce a decimal
1055 point. Note that width can be 0 only for %.0f. */
1058 for (cp
= buf
; *cp
; cp
++)
1059 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1062 if (*cp
== '.' && cp
[1] == 0)
1082 print (Lisp_Object obj
, Lisp_Object printcharfun
, bool escapeflag
)
1084 new_backquote_output
= 0;
1086 /* Reset print_number_index and Vprint_number_table only when
1087 the variable Vprint_continuous_numbering is nil. Otherwise,
1088 the values of these variables will be kept between several
1090 if (NILP (Vprint_continuous_numbering
)
1091 || NILP (Vprint_number_table
))
1093 print_number_index
= 0;
1094 Vprint_number_table
= Qnil
;
1097 /* Construct Vprint_number_table for print-gensym and print-circle. */
1098 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1100 /* Construct Vprint_number_table.
1101 This increments print_number_index for the objects added. */
1103 print_preprocess (obj
);
1105 if (HASH_TABLE_P (Vprint_number_table
))
1106 { /* Remove unnecessary objects, which appear only once in OBJ;
1107 that is, whose status is Qt. */
1108 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vprint_number_table
);
1111 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
1112 if (!NILP (HASH_HASH (h
, i
))
1113 && EQ (HASH_VALUE (h
, i
), Qt
))
1114 Fremhash (HASH_KEY (h
, i
), Vprint_number_table
);
1119 print_object (obj
, printcharfun
, escapeflag
);
1122 #define PRINT_CIRCLE_CANDIDATE_P(obj) \
1123 (STRINGP (obj) || CONSP (obj) \
1124 || (VECTORLIKEP (obj) \
1125 && (VECTORP (obj) || COMPILEDP (obj) \
1126 || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \
1127 || HASH_TABLE_P (obj) || FONTP (obj))) \
1128 || (! NILP (Vprint_gensym) \
1130 && !SYMBOL_INTERNED_P (obj)))
1132 /* Construct Vprint_number_table according to the structure of OBJ.
1133 OBJ itself and all its elements will be added to Vprint_number_table
1134 recursively if it is a list, vector, compiled function, char-table,
1135 string (its text properties will be traced), or a symbol that has
1136 no obarray (this is for the print-gensym feature).
1137 The status fields of Vprint_number_table mean whether each object appears
1138 more than once in OBJ: Qnil at the first time, and Qt after that. */
1140 print_preprocess (Lisp_Object obj
)
1145 Lisp_Object halftail
;
1147 /* Avoid infinite recursion for circular nested structure
1148 in the case where Vprint_circle is nil. */
1149 if (NILP (Vprint_circle
))
1151 /* Give up if we go so deep that print_object will get an error. */
1152 /* See similar code in print_object. */
1153 if (print_depth
>= PRINT_CIRCLE
)
1154 error ("Apparently circular structure being printed");
1156 for (i
= 0; i
< print_depth
; i
++)
1157 if (EQ (obj
, being_printed
[i
]))
1159 being_printed
[print_depth
] = obj
;
1166 if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1168 if (!HASH_TABLE_P (Vprint_number_table
))
1170 Lisp_Object args
[2];
1173 Vprint_number_table
= Fmake_hash_table (2, args
);
1176 /* In case print-circle is nil and print-gensym is t,
1177 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1178 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1180 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1182 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1183 always print the gensym with a number. This is a special for
1184 the lisp function byte-compile-output-docform. */
1185 || (!NILP (Vprint_continuous_numbering
)
1187 && !SYMBOL_INTERNED_P (obj
)))
1188 { /* OBJ appears more than once. Let's remember that. */
1189 if (!INTEGERP (num
))
1191 print_number_index
++;
1192 /* Negative number indicates it hasn't been printed yet. */
1193 Fputhash (obj
, make_number (- print_number_index
),
1194 Vprint_number_table
);
1200 /* OBJ is not yet recorded. Let's add to the table. */
1201 Fputhash (obj
, Qt
, Vprint_number_table
);
1204 switch (XTYPE (obj
))
1207 /* A string may have text properties, which can be circular. */
1208 traverse_intervals_noorder (string_intervals (obj
),
1209 print_preprocess_string
, Qnil
);
1213 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1214 just as in print_object. */
1215 if (loop_count
&& EQ (obj
, halftail
))
1217 print_preprocess (XCAR (obj
));
1220 if (!(loop_count
& 1))
1221 halftail
= XCDR (halftail
);
1224 case Lisp_Vectorlike
:
1226 if (size
& PSEUDOVECTOR_FLAG
)
1227 size
&= PSEUDOVECTOR_SIZE_MASK
;
1228 for (i
= 0; i
< size
; i
++)
1229 print_preprocess (AREF (obj
, i
));
1230 if (HASH_TABLE_P (obj
))
1231 { /* For hash tables, the key_and_value slot is past
1232 `size' because it needs to be marked specially in case
1233 the table is weak. */
1234 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1235 print_preprocess (h
->key_and_value
);
1247 print_preprocess_string (INTERVAL interval
, Lisp_Object arg
)
1249 print_preprocess (interval
->plist
);
1252 static void print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
);
1254 #define PRINT_STRING_NON_CHARSET_FOUND 1
1255 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1257 /* Bitwise or of the above macros. */
1258 static int print_check_string_result
;
1261 print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
)
1265 if (NILP (interval
->plist
)
1266 || (print_check_string_result
== (PRINT_STRING_NON_CHARSET_FOUND
1267 | PRINT_STRING_UNSAFE_CHARSET_FOUND
)))
1269 for (val
= interval
->plist
; CONSP (val
) && ! EQ (XCAR (val
), Qcharset
);
1270 val
= XCDR (XCDR (val
)));
1273 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1276 if (! (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
))
1278 if (! EQ (val
, interval
->plist
)
1279 || CONSP (XCDR (XCDR (val
))))
1280 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1282 if (NILP (Vprint_charset_text_property
)
1283 || ! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1286 ptrdiff_t charpos
= interval
->position
;
1287 ptrdiff_t bytepos
= string_char_to_byte (string
, charpos
);
1288 Lisp_Object charset
;
1290 charset
= XCAR (XCDR (val
));
1291 for (i
= 0; i
< LENGTH (interval
); i
++)
1293 FETCH_STRING_CHAR_ADVANCE (c
, string
, charpos
, bytepos
);
1294 if (! ASCII_CHAR_P (c
)
1295 && ! EQ (CHARSET_NAME (CHAR_CHARSET (c
)), charset
))
1297 print_check_string_result
|= PRINT_STRING_UNSAFE_CHARSET_FOUND
;
1304 /* The value is (charset . nil). */
1305 static Lisp_Object print_prune_charset_plist
;
1308 print_prune_string_charset (Lisp_Object string
)
1310 print_check_string_result
= 0;
1311 traverse_intervals (string_intervals (string
), 0,
1312 print_check_string_charset_prop
, string
);
1313 if (! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1315 string
= Fcopy_sequence (string
);
1316 if (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
)
1318 if (NILP (print_prune_charset_plist
))
1319 print_prune_charset_plist
= list1 (Qcharset
);
1320 Fremove_text_properties (make_number (0),
1321 make_number (SCHARS (string
)),
1322 print_prune_charset_plist
, string
);
1325 Fset_text_properties (make_number (0), make_number (SCHARS (string
)),
1332 print_object (Lisp_Object obj
, Lisp_Object printcharfun
, bool escapeflag
)
1334 char buf
[max (sizeof "from..to..in " + 2 * INT_STRLEN_BOUND (EMACS_INT
),
1335 max (sizeof " . #" + INT_STRLEN_BOUND (printmax_t
),
1340 /* Detect circularities and truncate them. */
1341 if (NILP (Vprint_circle
))
1343 /* Simple but incomplete way. */
1346 /* See similar code in print_preprocess. */
1347 if (print_depth
>= PRINT_CIRCLE
)
1348 error ("Apparently circular structure being printed");
1350 for (i
= 0; i
< print_depth
; i
++)
1351 if (EQ (obj
, being_printed
[i
]))
1353 int len
= sprintf (buf
, "#%d", i
);
1354 strout (buf
, len
, len
, printcharfun
);
1357 being_printed
[print_depth
] = obj
;
1359 else if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1361 /* With the print-circle feature. */
1362 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1365 EMACS_INT n
= XINT (num
);
1367 { /* Add a prefix #n= if OBJ has not yet been printed;
1368 that is, its status field is nil. */
1369 int len
= sprintf (buf
, "#%"pI
"d=", -n
);
1370 strout (buf
, len
, len
, printcharfun
);
1371 /* OBJ is going to be printed. Remember that fact. */
1372 Fputhash (obj
, make_number (- n
), Vprint_number_table
);
1376 /* Just print #n# if OBJ has already been printed. */
1377 int len
= sprintf (buf
, "#%"pI
"d#", n
);
1378 strout (buf
, len
, len
, printcharfun
);
1386 switch (XTYPE (obj
))
1390 int len
= sprintf (buf
, "%"pI
"d", XINT (obj
));
1391 strout (buf
, len
, len
, printcharfun
);
1397 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
1398 int len
= float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1399 strout (pigbuf
, len
, len
, printcharfun
);
1405 print_string (obj
, printcharfun
);
1408 register ptrdiff_t i
, i_byte
;
1409 struct gcpro gcpro1
;
1410 ptrdiff_t size_byte
;
1411 /* 1 means we must ensure that the next character we output
1412 cannot be taken as part of a hex character escape. */
1413 bool need_nonhex
= 0;
1414 bool multibyte
= STRING_MULTIBYTE (obj
);
1418 if (! EQ (Vprint_charset_text_property
, Qt
))
1419 obj
= print_prune_string_charset (obj
);
1421 if (string_intervals (obj
))
1428 size_byte
= SBYTES (obj
);
1430 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1432 /* Here, we must convert each multi-byte form to the
1433 corresponding character code before handing it to PRINTCHAR. */
1436 FETCH_STRING_CHAR_ADVANCE (c
, obj
, i
, i_byte
);
1440 if (c
== '\n' && print_escape_newlines
)
1445 else if (c
== '\f' && print_escape_newlines
)
1451 && (CHAR_BYTE8_P (c
)
1452 || (! ASCII_CHAR_P (c
) && print_escape_multibyte
)))
1454 /* When multibyte is disabled,
1455 print multibyte string chars using hex escapes.
1456 For a char code that could be in a unibyte string,
1457 when found in a multibyte string, always use a hex escape
1458 so it reads back as multibyte. */
1462 if (CHAR_BYTE8_P (c
))
1463 len
= sprintf (outbuf
, "\\%03o", CHAR_TO_BYTE8 (c
));
1466 len
= sprintf (outbuf
, "\\x%04x", c
);
1469 strout (outbuf
, len
, len
, printcharfun
);
1471 else if (! multibyte
1472 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_CHAR_P (c
)
1473 && print_escape_nonascii
)
1475 /* When printing in a multibyte buffer
1476 or when explicitly requested,
1477 print single-byte non-ASCII string chars
1478 using octal escapes. */
1480 int len
= sprintf (outbuf
, "\\%03o", c
);
1481 strout (outbuf
, len
, len
, printcharfun
);
1485 /* If we just had a hex escape, and this character
1486 could be taken as part of it,
1487 output `\ ' to prevent that. */
1491 if ((c
>= 'a' && c
<= 'f')
1492 || (c
>= 'A' && c
<= 'F')
1493 || (c
>= '0' && c
<= '9'))
1494 strout ("\\ ", -1, -1, printcharfun
);
1497 if (c
== '\"' || c
== '\\')
1504 if (string_intervals (obj
))
1506 traverse_intervals (string_intervals (obj
),
1507 0, print_interval
, printcharfun
);
1518 unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1519 unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1521 ptrdiff_t i
, i_byte
;
1522 ptrdiff_t size_byte
;
1525 name
= SYMBOL_NAME (obj
);
1527 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1530 /* If symbol name begins with a digit, and ends with a digit,
1531 and contains nothing but digits and `e', it could be treated
1532 as a number. So set CONFUSING.
1534 Symbols that contain periods could also be taken as numbers,
1535 but periods are always escaped, so we don't have to worry
1537 else if (*p
>= '0' && *p
<= '9'
1538 && end
[-1] >= '0' && end
[-1] <= '9')
1540 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1541 /* Needed for \2e10. */
1542 || *p
== 'e' || *p
== 'E'))
1544 confusing
= (end
== p
);
1549 size_byte
= SBYTES (name
);
1551 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1556 else if (size_byte
== 0)
1563 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1565 /* Here, we must convert each multi-byte form to the
1566 corresponding character code before handing it to PRINTCHAR. */
1567 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1572 if (c
== '\"' || c
== '\\' || c
== '\''
1573 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1574 || c
== ',' || c
== '.' || c
== '`'
1575 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1577 PRINTCHAR ('\\'), confusing
= 0;
1585 /* If deeper than spec'd depth, print placeholder. */
1586 if (INTEGERP (Vprint_level
)
1587 && print_depth
> XINT (Vprint_level
))
1588 strout ("...", -1, -1, printcharfun
);
1589 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1590 && (EQ (XCAR (obj
), Qquote
)))
1593 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1595 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1596 && (EQ (XCAR (obj
), Qfunction
)))
1600 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1602 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1603 && ((EQ (XCAR (obj
), Qbackquote
))))
1605 print_object (XCAR (obj
), printcharfun
, 0);
1606 new_backquote_output
++;
1607 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1608 new_backquote_output
--;
1610 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1611 && new_backquote_output
1612 && ((EQ (XCAR (obj
), Qbackquote
)
1613 || EQ (XCAR (obj
), Qcomma
)
1614 || EQ (XCAR (obj
), Qcomma_at
)
1615 || EQ (XCAR (obj
), Qcomma_dot
))))
1617 print_object (XCAR (obj
), printcharfun
, 0);
1618 new_backquote_output
--;
1619 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1620 new_backquote_output
++;
1627 printmax_t i
, print_length
;
1628 Lisp_Object halftail
= obj
;
1630 /* Negative values of print-length are invalid in CL.
1631 Treat them like nil, as CMUCL does. */
1632 if (NATNUMP (Vprint_length
))
1633 print_length
= XFASTINT (Vprint_length
);
1635 print_length
= TYPE_MAXIMUM (printmax_t
);
1640 /* Detect circular list. */
1641 if (NILP (Vprint_circle
))
1643 /* Simple but incomplete way. */
1644 if (i
!= 0 && EQ (obj
, halftail
))
1646 int len
= sprintf (buf
, " . #%"pMd
, i
/ 2);
1647 strout (buf
, len
, len
, printcharfun
);
1653 /* With the print-circle feature. */
1656 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1659 strout (" . ", 3, 3, printcharfun
);
1660 print_object (obj
, printcharfun
, escapeflag
);
1669 if (print_length
<= i
)
1671 strout ("...", 3, 3, printcharfun
);
1676 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1680 halftail
= XCDR (halftail
);
1684 /* OBJ non-nil here means it's the end of a dotted list. */
1687 strout (" . ", 3, 3, printcharfun
);
1688 print_object (obj
, printcharfun
, escapeflag
);
1696 case Lisp_Vectorlike
:
1701 strout ("#<process ", -1, -1, printcharfun
);
1702 print_string (XPROCESS (obj
)->name
, printcharfun
);
1706 print_string (XPROCESS (obj
)->name
, printcharfun
);
1708 else if (BOOL_VECTOR_P (obj
))
1713 struct gcpro gcpro1
;
1714 EMACS_INT size
= bool_vector_size (obj
);
1715 ptrdiff_t size_in_chars
= bool_vector_bytes (size
);
1716 ptrdiff_t real_size_in_chars
= size_in_chars
;
1721 len
= sprintf (buf
, "%"pI
"d", size
);
1722 strout (buf
, len
, len
, printcharfun
);
1725 /* Don't print more characters than the specified maximum.
1726 Negative values of print-length are invalid. Treat them
1727 like a print-length of nil. */
1728 if (NATNUMP (Vprint_length
)
1729 && XFASTINT (Vprint_length
) < size_in_chars
)
1730 size_in_chars
= XFASTINT (Vprint_length
);
1732 for (i
= 0; i
< size_in_chars
; i
++)
1735 c
= bool_vector_uchar_data (obj
)[i
];
1736 if (c
== '\n' && print_escape_newlines
)
1741 else if (c
== '\f' && print_escape_newlines
)
1746 else if (c
> '\177')
1748 /* Use octal escapes to avoid encoding issues. */
1750 PRINTCHAR ('0' + ((c
>> 6) & 3));
1751 PRINTCHAR ('0' + ((c
>> 3) & 7));
1752 PRINTCHAR ('0' + (c
& 7));
1756 if (c
== '\"' || c
== '\\')
1762 if (size_in_chars
< real_size_in_chars
)
1763 strout (" ...", 4, 4, printcharfun
);
1768 else if (SUBRP (obj
))
1770 strout ("#<subr ", -1, -1, printcharfun
);
1771 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
);
1774 else if (WINDOWP (obj
))
1777 strout ("#<window ", -1, -1, printcharfun
);
1778 len
= sprintf (buf
, "%d", XWINDOW (obj
)->sequence_number
);
1779 strout (buf
, len
, len
, printcharfun
);
1780 if (BUFFERP (XWINDOW (obj
)->contents
))
1782 strout (" on ", -1, -1, printcharfun
);
1783 print_string (BVAR (XBUFFER (XWINDOW (obj
)->contents
), name
),
1788 else if (TERMINALP (obj
))
1791 struct terminal
*t
= XTERMINAL (obj
);
1792 strout ("#<terminal ", -1, -1, printcharfun
);
1793 len
= sprintf (buf
, "%d", t
->id
);
1794 strout (buf
, len
, len
, printcharfun
);
1797 strout (" on ", -1, -1, printcharfun
);
1798 strout (t
->name
, -1, -1, printcharfun
);
1802 else if (HASH_TABLE_P (obj
))
1804 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1806 ptrdiff_t real_size
, size
;
1810 strout ("#<hash-table", -1, -1, printcharfun
);
1811 if (SYMBOLP (h
->test
))
1815 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
);
1817 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
);
1819 len
= sprintf (buf
, "%"pD
"d/%"pD
"d", h
->count
, ASIZE (h
->next
));
1820 strout (buf
, len
, len
, printcharfun
);
1822 len
= sprintf (buf
, " %p>", ptr
);
1823 strout (buf
, len
, len
, printcharfun
);
1825 /* Implement a readable output, e.g.:
1826 #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
1827 /* Always print the size. */
1828 len
= sprintf (buf
, "#s(hash-table size %"pD
"d", ASIZE (h
->next
));
1829 strout (buf
, len
, len
, printcharfun
);
1831 if (!NILP (h
->test
.name
))
1833 strout (" test ", -1, -1, printcharfun
);
1834 print_object (h
->test
.name
, printcharfun
, escapeflag
);
1837 if (!NILP (h
->weak
))
1839 strout (" weakness ", -1, -1, printcharfun
);
1840 print_object (h
->weak
, printcharfun
, escapeflag
);
1843 if (!NILP (h
->rehash_size
))
1845 strout (" rehash-size ", -1, -1, printcharfun
);
1846 print_object (h
->rehash_size
, printcharfun
, escapeflag
);
1849 if (!NILP (h
->rehash_threshold
))
1851 strout (" rehash-threshold ", -1, -1, printcharfun
);
1852 print_object (h
->rehash_threshold
, printcharfun
, escapeflag
);
1855 strout (" data ", -1, -1, printcharfun
);
1857 /* Print the data here as a plist. */
1858 real_size
= HASH_TABLE_SIZE (h
);
1861 /* Don't print more elements than the specified maximum. */
1862 if (NATNUMP (Vprint_length
)
1863 && XFASTINT (Vprint_length
) < size
)
1864 size
= XFASTINT (Vprint_length
);
1867 for (i
= 0; i
< size
; i
++)
1868 if (!NILP (HASH_HASH (h
, i
)))
1870 if (i
) PRINTCHAR (' ');
1871 print_object (HASH_KEY (h
, i
), printcharfun
, escapeflag
);
1873 print_object (HASH_VALUE (h
, i
), printcharfun
, escapeflag
);
1876 if (size
< real_size
)
1877 strout (" ...", 4, 4, printcharfun
);
1883 else if (BUFFERP (obj
))
1885 if (!BUFFER_LIVE_P (XBUFFER (obj
)))
1886 strout ("#<killed buffer>", -1, -1, printcharfun
);
1887 else if (escapeflag
)
1889 strout ("#<buffer ", -1, -1, printcharfun
);
1890 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1894 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1896 else if (WINDOW_CONFIGURATIONP (obj
))
1898 strout ("#<window-configuration>", -1, -1, printcharfun
);
1900 else if (FRAMEP (obj
))
1903 void *ptr
= XFRAME (obj
);
1904 Lisp_Object frame_name
= XFRAME (obj
)->name
;
1906 strout ((FRAME_LIVE_P (XFRAME (obj
))
1907 ? "#<frame " : "#<dead frame "),
1908 -1, -1, printcharfun
);
1909 if (!STRINGP (frame_name
))
1911 /* A frame could be too young and have no name yet;
1913 if (SYMBOLP (frame_name
))
1914 frame_name
= Fsymbol_name (frame_name
);
1915 else /* can't happen: name should be either nil or string */
1916 frame_name
= build_string ("*INVALID*FRAME*NAME*");
1918 print_string (frame_name
, printcharfun
);
1919 len
= sprintf (buf
, " %p>", ptr
);
1920 strout (buf
, len
, len
, printcharfun
);
1922 else if (FONTP (obj
))
1926 if (! FONT_OBJECT_P (obj
))
1928 if (FONT_SPEC_P (obj
))
1929 strout ("#<font-spec", -1, -1, printcharfun
);
1931 strout ("#<font-entity", -1, -1, printcharfun
);
1932 for (i
= 0; i
< FONT_SPEC_MAX
; i
++)
1935 if (i
< FONT_WEIGHT_INDEX
|| i
> FONT_WIDTH_INDEX
)
1936 print_object (AREF (obj
, i
), printcharfun
, escapeflag
);
1938 print_object (font_style_symbolic (obj
, i
, 0),
1939 printcharfun
, escapeflag
);
1944 strout ("#<font-object ", -1, -1, printcharfun
);
1945 print_object (AREF (obj
, FONT_NAME_INDEX
), printcharfun
,
1952 ptrdiff_t size
= ASIZE (obj
);
1953 if (COMPILEDP (obj
))
1956 size
&= PSEUDOVECTOR_SIZE_MASK
;
1958 if (CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
))
1960 /* We print a char-table as if it were a vector,
1961 lumping the parent and default slots in with the
1962 character slots. But we add #^ as a prefix. */
1964 /* Make each lowest sub_char_table start a new line.
1965 Otherwise we'll make a line extremely long, which
1966 results in slow redisplay. */
1967 if (SUB_CHAR_TABLE_P (obj
)
1968 && XINT (XSUB_CHAR_TABLE (obj
)->depth
) == 3)
1972 if (SUB_CHAR_TABLE_P (obj
))
1974 size
&= PSEUDOVECTOR_SIZE_MASK
;
1976 if (size
& PSEUDOVECTOR_FLAG
)
1982 register Lisp_Object tem
;
1983 ptrdiff_t real_size
= size
;
1985 /* Don't print more elements than the specified maximum. */
1986 if (NATNUMP (Vprint_length
)
1987 && XFASTINT (Vprint_length
) < size
)
1988 size
= XFASTINT (Vprint_length
);
1990 for (i
= 0; i
< size
; i
++)
1992 if (i
) PRINTCHAR (' ');
1993 tem
= AREF (obj
, i
);
1994 print_object (tem
, printcharfun
, escapeflag
);
1996 if (size
< real_size
)
1997 strout (" ...", 4, 4, printcharfun
);
2004 switch (XMISCTYPE (obj
))
2006 case Lisp_Misc_Marker
:
2007 strout ("#<marker ", -1, -1, printcharfun
);
2008 /* Do you think this is necessary? */
2009 if (XMARKER (obj
)->insertion_type
!= 0)
2010 strout ("(moves after insertion) ", -1, -1, printcharfun
);
2011 if (! XMARKER (obj
)->buffer
)
2012 strout ("in no buffer", -1, -1, printcharfun
);
2015 int len
= sprintf (buf
, "at %"pD
"d", marker_position (obj
));
2016 strout (buf
, len
, len
, printcharfun
);
2017 strout (" in ", -1, -1, printcharfun
);
2018 print_string (BVAR (XMARKER (obj
)->buffer
, name
), printcharfun
);
2023 case Lisp_Misc_Overlay
:
2024 strout ("#<overlay ", -1, -1, printcharfun
);
2025 if (! XMARKER (OVERLAY_START (obj
))->buffer
)
2026 strout ("in no buffer", -1, -1, printcharfun
);
2029 int len
= sprintf (buf
, "from %"pD
"d to %"pD
"d in ",
2030 marker_position (OVERLAY_START (obj
)),
2031 marker_position (OVERLAY_END (obj
)));
2032 strout (buf
, len
, len
, printcharfun
);
2033 print_string (BVAR (XMARKER (OVERLAY_START (obj
))->buffer
, name
),
2039 /* Remaining cases shouldn't happen in normal usage, but let's
2040 print them anyway for the benefit of the debugger. */
2042 case Lisp_Misc_Free
:
2043 strout ("#<misc free cell>", -1, -1, printcharfun
);
2046 case Lisp_Misc_Save_Value
:
2049 struct Lisp_Save_Value
*v
= XSAVE_VALUE (obj
);
2051 strout ("#<save-value ", -1, -1, printcharfun
);
2053 if (v
->save_type
== SAVE_TYPE_MEMORY
)
2055 ptrdiff_t amount
= v
->data
[1].integer
;
2059 /* valid_lisp_object_p is reliable, so try to print up
2060 to 8 saved objects. This code is rarely used, so
2061 it's OK that valid_lisp_object_p is slow. */
2063 int limit
= min (amount
, 8);
2064 Lisp_Object
*area
= v
->data
[0].pointer
;
2066 i
= sprintf (buf
, "with %"pD
"d objects", amount
);
2067 strout (buf
, i
, i
, printcharfun
);
2069 for (i
= 0; i
< limit
; i
++)
2071 Lisp_Object maybe
= area
[i
];
2073 if (valid_lisp_object_p (maybe
) > 0)
2076 print_object (maybe
, printcharfun
, escapeflag
);
2079 strout (" <invalid>", -1, -1, printcharfun
);
2081 if (i
== limit
&& i
< amount
)
2082 strout (" ...", 4, 4, printcharfun
);
2084 #else /* not GC_MARK_STACK */
2086 /* There is no reliable way to determine whether the objects
2087 are initialized, so do not try to print them. */
2089 i
= sprintf (buf
, "with %"pD
"d objects", amount
);
2090 strout (buf
, i
, i
, printcharfun
);
2092 #endif /* GC_MARK_STACK */
2096 /* Print each slot according to its type. */
2098 for (index
= 0; index
< SAVE_VALUE_SLOTS
; index
++)
2103 switch (save_type (v
, index
))
2106 i
= sprintf (buf
, "<unused>");
2110 i
= sprintf (buf
, "<pointer %p>",
2111 v
->data
[index
].pointer
);
2114 case SAVE_FUNCPOINTER
:
2115 i
= sprintf (buf
, "<funcpointer %p>",
2116 ((void *) (intptr_t)
2117 v
->data
[index
].funcpointer
));
2121 i
= sprintf (buf
, "<integer %"pD
"d>",
2122 v
->data
[index
].integer
);
2126 print_object (v
->data
[index
].object
, printcharfun
,
2134 strout (buf
, i
, i
, printcharfun
);
2150 /* We're in trouble if this happens!
2151 Probably should just emacs_abort (). */
2152 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
);
2154 len
= sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2155 else if (VECTORLIKEP (obj
))
2156 len
= sprintf (buf
, "(PVEC 0x%08"pD
"x)", ASIZE (obj
));
2158 len
= sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2159 strout (buf
, len
, len
, printcharfun
);
2160 strout (" Save your buffers immediately and please report this bug>",
2161 -1, -1, printcharfun
);
2169 /* Print a description of INTERVAL using PRINTCHARFUN.
2170 This is part of printing a string that has text properties. */
2173 print_interval (INTERVAL interval
, Lisp_Object printcharfun
)
2175 if (NILP (interval
->plist
))
2178 print_object (make_number (interval
->position
), printcharfun
, 1);
2180 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2183 print_object (interval
->plist
, printcharfun
, 1);
2186 /* Initialize debug_print stuff early to have it working from the very
2190 init_print_once (void)
2192 DEFSYM (Qexternal_debugging_output
, "external-debugging-output");
2193 defsubr (&Sexternal_debugging_output
);
2197 syms_of_print (void)
2199 DEFSYM (Qtemp_buffer_setup_hook
, "temp-buffer-setup-hook");
2201 DEFVAR_LISP ("standard-output", Vstandard_output
,
2202 doc
: /* Output stream `print' uses by default for outputting a character.
2203 This may be any function of one argument.
2204 It may also be a buffer (output is inserted before point)
2205 or a marker (output is inserted and the marker is advanced)
2206 or the symbol t (output appears in the echo area). */);
2207 Vstandard_output
= Qt
;
2208 DEFSYM (Qstandard_output
, "standard-output");
2210 DEFVAR_LISP ("float-output-format", Vfloat_output_format
,
2211 doc
: /* The format descriptor string used to print floats.
2212 This is a %-spec like those accepted by `printf' in C,
2213 but with some restrictions. It must start with the two characters `%.'.
2214 After that comes an integer precision specification,
2215 and then a letter which controls the format.
2216 The letters allowed are `e', `f' and `g'.
2217 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2218 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2219 Use `g' to choose the shorter of those two formats for the number at hand.
2220 The precision in any of these cases is the number of digits following
2221 the decimal point. With `f', a precision of 0 means to omit the
2222 decimal point. 0 is not allowed with `e' or `g'.
2224 A value of nil means to use the shortest notation
2225 that represents the number without losing information. */);
2226 Vfloat_output_format
= Qnil
;
2227 DEFSYM (Qfloat_output_format
, "float-output-format");
2229 DEFVAR_LISP ("print-length", Vprint_length
,
2230 doc
: /* Maximum length of list to print before abbreviating.
2231 A value of nil means no limit. See also `eval-expression-print-length'. */);
2232 Vprint_length
= Qnil
;
2234 DEFVAR_LISP ("print-level", Vprint_level
,
2235 doc
: /* Maximum depth of list nesting to print before abbreviating.
2236 A value of nil means no limit. See also `eval-expression-print-level'. */);
2237 Vprint_level
= Qnil
;
2239 DEFVAR_BOOL ("print-escape-newlines", print_escape_newlines
,
2240 doc
: /* Non-nil means print newlines in strings as `\\n'.
2241 Also print formfeeds as `\\f'. */);
2242 print_escape_newlines
= 0;
2244 DEFVAR_BOOL ("print-escape-nonascii", print_escape_nonascii
,
2245 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2246 \(OOO is the octal representation of the character code.)
2247 Only single-byte characters are affected, and only in `prin1'.
2248 When the output goes in a multibyte buffer, this feature is
2249 enabled regardless of the value of the variable. */);
2250 print_escape_nonascii
= 0;
2252 DEFVAR_BOOL ("print-escape-multibyte", print_escape_multibyte
,
2253 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2254 \(XXXX is the hex representation of the character code.)
2255 This affects only `prin1'. */);
2256 print_escape_multibyte
= 0;
2258 DEFVAR_BOOL ("print-quoted", print_quoted
,
2259 doc
: /* Non-nil means print quoted forms with reader syntax.
2260 I.e., (quote foo) prints as 'foo, (function foo) as #'foo. */);
2263 DEFVAR_LISP ("print-gensym", Vprint_gensym
,
2264 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2265 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2266 When the uninterned symbol appears within a recursive data structure,
2267 and the symbol appears more than once, in addition use the #N# and #N=
2268 constructs as needed, so that multiple references to the same symbol are
2269 shared once again when the text is read back. */);
2270 Vprint_gensym
= Qnil
;
2272 DEFVAR_LISP ("print-circle", Vprint_circle
,
2273 doc
: /* Non-nil means print recursive structures using #N= and #N# syntax.
2274 If nil, printing proceeds recursively and may lead to
2275 `max-lisp-eval-depth' being exceeded or an error may occur:
2276 \"Apparently circular structure being printed.\" Also see
2277 `print-length' and `print-level'.
2278 If non-nil, shared substructures anywhere in the structure are printed
2279 with `#N=' before the first occurrence (in the order of the print
2280 representation) and `#N#' in place of each subsequent occurrence,
2281 where N is a positive decimal integer. */);
2282 Vprint_circle
= Qnil
;
2284 DEFVAR_LISP ("print-continuous-numbering", Vprint_continuous_numbering
,
2285 doc
: /* Non-nil means number continuously across print calls.
2286 This affects the numbers printed for #N= labels and #M# references.
2287 See also `print-circle', `print-gensym', and `print-number-table'.
2288 This variable should not be set with `setq'; bind it with a `let' instead. */);
2289 Vprint_continuous_numbering
= Qnil
;
2291 DEFVAR_LISP ("print-number-table", Vprint_number_table
,
2292 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2293 The Lisp printer uses this vector to detect Lisp objects referenced more
2296 When you bind `print-continuous-numbering' to t, you should probably
2297 also bind `print-number-table' to nil. This ensures that the value of
2298 `print-number-table' can be garbage-collected once the printing is
2299 done. If all elements of `print-number-table' are nil, it means that
2300 the printing done so far has not found any shared structure or objects
2301 that need to be recorded in the table. */);
2302 Vprint_number_table
= Qnil
;
2304 DEFVAR_LISP ("print-charset-text-property", Vprint_charset_text_property
,
2305 doc
: /* A flag to control printing of `charset' text property on printing a string.
2306 The value must be nil, t, or `default'.
2308 If the value is nil, don't print the text property `charset'.
2310 If the value is t, always print the text property `charset'.
2312 If the value is `default', print the text property `charset' only when
2313 the value is different from what is guessed in the current charset
2315 Vprint_charset_text_property
= Qdefault
;
2317 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2318 staticpro (&Vprin1_to_string_buffer
);
2321 defsubr (&Sprin1_to_string
);
2322 defsubr (&Serror_message_string
);
2326 defsubr (&Swrite_char
);
2327 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2328 defsubr (&Sredirect_debugging_output
);
2331 DEFSYM (Qprint_escape_newlines
, "print-escape-newlines");
2332 DEFSYM (Qprint_escape_multibyte
, "print-escape-multibyte");
2333 DEFSYM (Qprint_escape_nonascii
, "print-escape-nonascii");
2335 print_prune_charset_plist
= Qnil
;
2336 staticpro (&print_prune_charset_plist
);