1 /* Lisp object printing and output streams.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2015 Free Software
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
26 #include "character.h"
33 #include "dispextern.h"
35 #include "intervals.h"
36 #include "blockinput.h"
37 #include "termhooks.h" /* For struct terminal. */
43 /* Avoid actual stack overflow in print. */
44 static ptrdiff_t print_depth
;
46 /* Level of nesting inside outputting backquote in new style. */
47 static ptrdiff_t new_backquote_output
;
49 /* Detect most circularities to print finite output. */
50 #define PRINT_CIRCLE 200
51 static Lisp_Object being_printed
[PRINT_CIRCLE
];
53 /* Last char printed to stdout by printchar. */
54 static unsigned int printchar_stdout_last
;
56 /* When printing into a buffer, first we put the text in this
57 block, then insert it all at once. */
58 static char *print_buffer
;
60 /* Size allocated in print_buffer. */
61 static ptrdiff_t print_buffer_size
;
62 /* Chars stored in print_buffer. */
63 static ptrdiff_t print_buffer_pos
;
64 /* Bytes stored in print_buffer. */
65 static ptrdiff_t print_buffer_pos_byte
;
67 /* Vprint_number_table is a table, that keeps objects that are going to
68 be printed, to allow use of #n= and #n# to express sharing.
69 For any given object, the table can give the following values:
70 t the object will be printed only once.
71 -N the object will be printed several times and will take number N.
72 N the object has been printed so we can refer to it as #N#.
73 print_number_index holds the largest N already used.
74 N has to be striclty larger than 0 since we need to distinguish -N. */
75 static ptrdiff_t print_number_index
;
76 static void print_interval (INTERVAL interval
, Lisp_Object printcharfun
);
78 /* GDB resets this to zero on W32 to disable OutputDebugString calls. */
79 bool print_output_debug_flag EXTERNALLY_VISIBLE
= 1;
82 /* Low level output routines for characters and strings. */
84 /* Lisp functions to do output using a stream
85 must have the stream in a variable called printcharfun
86 and must start with PRINTPREPARE, end with PRINTFINISH,
87 and use PRINTDECLARE to declare common variables.
88 Use PRINTCHAR to output one character,
89 or call strout to output a block of characters. */
91 #define PRINTDECLARE \
92 struct buffer *old = current_buffer; \
93 ptrdiff_t old_point = -1, start_point = -1; \
94 ptrdiff_t old_point_byte = -1, start_point_byte = -1; \
95 ptrdiff_t specpdl_count = SPECPDL_INDEX (); \
96 bool free_print_buffer = 0; \
98 = !NILP (BVAR (current_buffer, enable_multibyte_characters)); \
101 #define PRINTPREPARE \
102 original = printcharfun; \
103 if (NILP (printcharfun)) printcharfun = Qt; \
104 if (BUFFERP (printcharfun)) \
106 if (XBUFFER (printcharfun) != current_buffer) \
107 Fset_buffer (printcharfun); \
108 printcharfun = Qnil; \
110 if (MARKERP (printcharfun)) \
112 ptrdiff_t marker_pos; \
113 if (! XMARKER (printcharfun)->buffer) \
114 error ("Marker does not point anywhere"); \
115 if (XMARKER (printcharfun)->buffer != current_buffer) \
116 set_buffer_internal (XMARKER (printcharfun)->buffer); \
117 marker_pos = marker_position (printcharfun); \
118 if (marker_pos < BEGV || marker_pos > ZV) \
119 signal_error ("Marker is outside the accessible " \
120 "part of the buffer", printcharfun); \
122 old_point_byte = PT_BYTE; \
123 SET_PT_BOTH (marker_pos, \
124 marker_byte_position (printcharfun)); \
126 start_point_byte = PT_BYTE; \
127 printcharfun = Qnil; \
129 if (NILP (printcharfun)) \
131 Lisp_Object string; \
132 if (NILP (BVAR (current_buffer, enable_multibyte_characters)) \
133 && ! print_escape_multibyte) \
134 specbind (Qprint_escape_multibyte, Qt); \
135 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)) \
136 && ! print_escape_nonascii) \
137 specbind (Qprint_escape_nonascii, Qt); \
138 if (print_buffer != 0) \
140 string = make_string_from_bytes (print_buffer, \
142 print_buffer_pos_byte); \
143 record_unwind_protect (print_unwind, string); \
147 int new_size = 1000; \
148 print_buffer = xmalloc (new_size); \
149 print_buffer_size = new_size; \
150 free_print_buffer = 1; \
152 print_buffer_pos = 0; \
153 print_buffer_pos_byte = 0; \
155 if (EQ (printcharfun, Qt) && ! noninteractive) \
156 setup_echo_area_for_printing (multibyte);
158 #define PRINTFINISH \
159 if (NILP (printcharfun)) \
161 if (print_buffer_pos != print_buffer_pos_byte \
162 && NILP (BVAR (current_buffer, enable_multibyte_characters)))\
165 unsigned char *temp = SAFE_ALLOCA (print_buffer_pos + 1); \
166 copy_text ((unsigned char *) print_buffer, temp, \
167 print_buffer_pos_byte, 1, 0); \
168 insert_1_both ((char *) temp, print_buffer_pos, \
169 print_buffer_pos, 0, 1, 0); \
173 insert_1_both (print_buffer, print_buffer_pos, \
174 print_buffer_pos_byte, 0, 1, 0); \
175 signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
177 if (free_print_buffer) \
179 xfree (print_buffer); \
182 unbind_to (specpdl_count, Qnil); \
183 if (MARKERP (original)) \
184 set_marker_both (original, Qnil, PT, PT_BYTE); \
185 if (old_point >= 0) \
186 SET_PT_BOTH (old_point + (old_point >= start_point \
187 ? PT - start_point : 0), \
188 old_point_byte + (old_point_byte >= start_point_byte \
189 ? PT_BYTE - start_point_byte : 0)); \
190 set_buffer_internal (old);
192 #define PRINTCHAR(ch) printchar (ch, printcharfun)
194 /* This is used to restore the saved contents of print_buffer
195 when there is a recursive call to print. */
198 print_unwind (Lisp_Object saved_text
)
200 memcpy (print_buffer
, SDATA (saved_text
), SCHARS (saved_text
));
204 /* Print character CH using method FUN. FUN nil means print to
205 print_buffer. FUN t means print to echo area or stdout if
206 non-interactive. If FUN is neither nil nor t, call FUN with CH as
210 printchar (unsigned int ch
, Lisp_Object fun
)
212 if (!NILP (fun
) && !EQ (fun
, Qt
))
213 call1 (fun
, make_number (ch
));
216 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
217 int len
= CHAR_STRING (ch
, str
);
223 ptrdiff_t incr
= len
- (print_buffer_size
- print_buffer_pos_byte
);
225 print_buffer
= xpalloc (print_buffer
, &print_buffer_size
,
227 memcpy (print_buffer
+ print_buffer_pos_byte
, str
, len
);
228 print_buffer_pos
+= 1;
229 print_buffer_pos_byte
+= len
;
231 else if (noninteractive
)
233 printchar_stdout_last
= ch
;
234 fwrite (str
, 1, len
, stdout
);
235 noninteractive_need_newline
= 1;
240 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
242 setup_echo_area_for_printing (multibyte_p
);
244 message_dolog ((char *) str
, len
, 0, multibyte_p
);
250 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
251 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
252 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
253 print_buffer. PRINTCHARFUN t means output to the echo area or to
254 stdout if non-interactive. If neither nil nor t, call Lisp
255 function PRINTCHARFUN for each character printed. MULTIBYTE
256 non-zero means PTR contains multibyte characters.
258 In the case where PRINTCHARFUN is nil, it is safe for PTR to point
259 to data in a Lisp string. Otherwise that is not safe. */
262 strout (const char *ptr
, ptrdiff_t size
, ptrdiff_t size_byte
,
263 Lisp_Object printcharfun
)
266 size_byte
= size
= strlen (ptr
);
268 if (NILP (printcharfun
))
270 ptrdiff_t incr
= size_byte
- (print_buffer_size
- print_buffer_pos_byte
);
272 print_buffer
= xpalloc (print_buffer
, &print_buffer_size
, incr
, -1, 1);
273 memcpy (print_buffer
+ print_buffer_pos_byte
, ptr
, size_byte
);
274 print_buffer_pos
+= size
;
275 print_buffer_pos_byte
+= size_byte
;
277 else if (noninteractive
&& EQ (printcharfun
, Qt
))
279 fwrite (ptr
, 1, size_byte
, stdout
);
280 noninteractive_need_newline
= 1;
282 else if (EQ (printcharfun
, Qt
))
284 /* Output to echo area. We're trying to avoid a little overhead
285 here, that's the reason we don't call printchar to do the
289 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
291 setup_echo_area_for_printing (multibyte_p
);
292 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
294 if (size
== size_byte
)
296 for (i
= 0; i
< size
; ++i
)
297 insert_char ((unsigned char) *ptr
++);
302 for (i
= 0; i
< size_byte
; i
+= len
)
304 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
312 /* PRINTCHARFUN is a Lisp function. */
315 if (size
== size_byte
)
317 while (i
< size_byte
)
325 while (i
< size_byte
)
327 /* Here, we must convert each multi-byte form to the
328 corresponding character code before handing it to
331 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
340 /* Print the contents of a string STRING using PRINTCHARFUN.
341 It isn't safe to use strout in many cases,
342 because printing one char can relocate. */
345 print_string (Lisp_Object string
, Lisp_Object printcharfun
)
347 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
351 if (print_escape_nonascii
)
352 string
= string_escape_byte8 (string
);
354 if (STRING_MULTIBYTE (string
))
355 chars
= SCHARS (string
);
356 else if (! print_escape_nonascii
357 && (EQ (printcharfun
, Qt
)
358 ? ! NILP (BVAR (&buffer_defaults
, enable_multibyte_characters
))
359 : ! NILP (BVAR (current_buffer
, enable_multibyte_characters
))))
361 /* If unibyte string STRING contains 8-bit codes, we must
362 convert STRING to a multibyte string containing the same
367 chars
= SBYTES (string
);
368 bytes
= count_size_as_multibyte (SDATA (string
), chars
);
371 newstr
= make_uninit_multibyte_string (chars
, bytes
);
372 memcpy (SDATA (newstr
), SDATA (string
), chars
);
373 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
378 chars
= SBYTES (string
);
380 if (EQ (printcharfun
, Qt
))
382 /* Output to echo area. */
383 ptrdiff_t nbytes
= SBYTES (string
);
385 /* Copy the string contents so that relocation of STRING by
386 GC does not cause trouble. */
388 char *buffer
= SAFE_ALLOCA (nbytes
);
389 memcpy (buffer
, SDATA (string
), nbytes
);
391 strout (buffer
, chars
, nbytes
, printcharfun
);
396 /* No need to copy, since output to print_buffer can't GC. */
397 strout (SSDATA (string
), chars
, SBYTES (string
), printcharfun
);
401 /* Otherwise, string may be relocated by printing one char.
402 So re-fetch the string address for each character. */
404 ptrdiff_t size
= SCHARS (string
);
405 ptrdiff_t size_byte
= SBYTES (string
);
408 if (size
== size_byte
)
409 for (i
= 0; i
< size
; i
++)
410 PRINTCHAR (SREF (string
, i
));
412 for (i
= 0; i
< size_byte
; )
414 /* Here, we must convert each multi-byte form to the
415 corresponding character code before handing it to PRINTCHAR. */
417 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
, len
);
425 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
426 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
427 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
428 (Lisp_Object character
, Lisp_Object printcharfun
)
432 if (NILP (printcharfun
))
433 printcharfun
= Vstandard_output
;
434 CHECK_NUMBER (character
);
436 PRINTCHAR (XINT (character
));
441 /* Used from outside of print.c to print a block of SIZE
442 single-byte chars at DATA on the default output stream.
443 Do not use this on the contents of a Lisp string. */
446 write_string (const char *data
, int size
)
449 Lisp_Object printcharfun
;
451 printcharfun
= Vstandard_output
;
454 strout (data
, size
, size
, printcharfun
);
458 /* Used to print a block of SIZE single-byte chars at DATA on a
459 specified stream PRINTCHARFUN.
460 Do not use this on the contents of a Lisp string. */
463 write_string_1 (const char *data
, int size
, Lisp_Object printcharfun
)
468 strout (data
, size
, size
, printcharfun
);
474 temp_output_buffer_setup (const char *bufname
)
476 ptrdiff_t count
= SPECPDL_INDEX ();
477 register struct buffer
*old
= current_buffer
;
478 register Lisp_Object buf
;
480 record_unwind_current_buffer ();
482 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
484 Fkill_all_local_variables ();
485 delete_all_overlays (current_buffer
);
486 bset_directory (current_buffer
, BVAR (old
, directory
));
487 bset_read_only (current_buffer
, Qnil
);
488 bset_filename (current_buffer
, Qnil
);
489 bset_undo_list (current_buffer
, Qt
);
490 eassert (current_buffer
->overlays_before
== NULL
);
491 eassert (current_buffer
->overlays_after
== NULL
);
492 bset_enable_multibyte_characters
493 (current_buffer
, BVAR (&buffer_defaults
, enable_multibyte_characters
));
494 specbind (Qinhibit_read_only
, Qt
);
495 specbind (Qinhibit_modification_hooks
, Qt
);
497 XSETBUFFER (buf
, current_buffer
);
499 run_hook (Qtemp_buffer_setup_hook
);
501 unbind_to (count
, Qnil
);
503 specbind (Qstandard_output
, buf
);
506 static void print (Lisp_Object
, Lisp_Object
, bool);
507 static void print_preprocess (Lisp_Object
);
508 static void print_preprocess_string (INTERVAL
, Lisp_Object
);
509 static void print_object (Lisp_Object
, Lisp_Object
, bool);
511 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 2, 0,
512 doc
: /* Output a newline to stream PRINTCHARFUN.
513 If ENSURE is non-nil only output a newline if not already at the
514 beginning of a line. Value is non-nil if a newline is printed.
515 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
516 (Lisp_Object printcharfun
, Lisp_Object ensure
)
518 Lisp_Object val
= Qnil
;
521 if (NILP (printcharfun
))
522 printcharfun
= Vstandard_output
;
527 /* Difficult to check if at line beginning so abort. */
528 else if (FUNCTIONP (printcharfun
))
529 signal_error ("Unsupported function argument", printcharfun
);
530 else if (noninteractive
&& !NILP (printcharfun
))
531 val
= printchar_stdout_last
== 10 ? Qnil
: Qt
;
532 else if (NILP (Fbolp ()))
535 if (!NILP (val
)) PRINTCHAR ('\n');
540 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
541 doc
: /* Output the printed representation of OBJECT, any Lisp object.
542 Quoting characters are printed when needed to make output that `read'
543 can handle, whenever this is possible. For complex objects, the behavior
544 is controlled by `print-level' and `print-length', which see.
546 OBJECT is any of the Lisp data types: a number, a string, a symbol,
547 a list, a buffer, a window, a frame, etc.
549 A printed representation of an object is text which describes that object.
551 Optional argument PRINTCHARFUN is the output stream, which can be one
554 - a buffer, in which case output is inserted into that buffer at point;
555 - a marker, in which case output is inserted at marker's position;
556 - a function, in which case that function is called once for each
557 character of OBJECT's printed representation;
558 - a symbol, in which case that symbol's function definition is called; or
559 - t, in which case the output is displayed in the echo area.
561 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
563 (Lisp_Object object
, Lisp_Object printcharfun
)
567 if (NILP (printcharfun
))
568 printcharfun
= Vstandard_output
;
570 print (object
, printcharfun
, 1);
575 /* a buffer which is used to hold output being built by prin1-to-string */
576 Lisp_Object Vprin1_to_string_buffer
;
578 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
579 doc
: /* Return a string containing the printed representation of OBJECT.
580 OBJECT can be any Lisp object. This function outputs quoting characters
581 when necessary to make output that `read' can handle, whenever possible,
582 unless the optional second argument NOESCAPE is non-nil. For complex objects,
583 the behavior is controlled by `print-level' and `print-length', which see.
585 OBJECT is any of the Lisp data types: a number, a string, a symbol,
586 a list, a buffer, a window, a frame, etc.
588 A printed representation of an object is text which describes that object. */)
589 (Lisp_Object object
, Lisp_Object noescape
)
591 Lisp_Object printcharfun
;
592 bool prev_abort_on_gc
;
593 Lisp_Object save_deactivate_mark
;
594 ptrdiff_t count
= SPECPDL_INDEX ();
595 struct buffer
*previous
;
597 specbind (Qinhibit_modification_hooks
, Qt
);
602 /* Save and restore this--we are altering a buffer
603 but we don't want to deactivate the mark just for that.
604 No need for specbind, since errors deactivate the mark. */
605 save_deactivate_mark
= Vdeactivate_mark
;
606 prev_abort_on_gc
= abort_on_gc
;
609 printcharfun
= Vprin1_to_string_buffer
;
611 print (object
, printcharfun
, NILP (noescape
));
612 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINISH */
616 previous
= current_buffer
;
617 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
618 object
= Fbuffer_string ();
619 if (SBYTES (object
) == SCHARS (object
))
620 STRING_SET_UNIBYTE (object
);
622 /* Note that this won't make prepare_to_modify_buffer call
623 ask-user-about-supersession-threat because this buffer
624 does not visit a file. */
626 set_buffer_internal (previous
);
628 Vdeactivate_mark
= save_deactivate_mark
;
630 abort_on_gc
= prev_abort_on_gc
;
631 return unbind_to (count
, object
);
634 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
635 doc
: /* Output the printed representation of OBJECT, any Lisp object.
636 No quoting characters are used; no delimiters are printed around
637 the contents of strings.
639 OBJECT is any of the Lisp data types: a number, a string, a symbol,
640 a list, a buffer, a window, a frame, etc.
642 A printed representation of an object is text which describes that object.
644 Optional argument PRINTCHARFUN is the output stream, which can be one
647 - a buffer, in which case output is inserted into that buffer at point;
648 - a marker, in which case output is inserted at marker's position;
649 - a function, in which case that function is called once for each
650 character of OBJECT's printed representation;
651 - a symbol, in which case that symbol's function definition is called; or
652 - t, in which case the output is displayed in the echo area.
654 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
656 (Lisp_Object object
, Lisp_Object printcharfun
)
660 if (NILP (printcharfun
))
661 printcharfun
= Vstandard_output
;
663 print (object
, printcharfun
, 0);
668 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
669 doc
: /* Output the printed representation of OBJECT, with newlines around it.
670 Quoting characters are printed when needed to make output that `read'
671 can handle, whenever this is possible. For complex objects, the behavior
672 is controlled by `print-level' and `print-length', which see.
674 OBJECT is any of the Lisp data types: a number, a string, a symbol,
675 a list, a buffer, a window, a frame, etc.
677 A printed representation of an object is text which describes that object.
679 Optional argument PRINTCHARFUN is the output stream, which can be one
682 - a buffer, in which case output is inserted into that buffer at point;
683 - a marker, in which case output is inserted at marker's position;
684 - a function, in which case that function is called once for each
685 character of OBJECT's printed representation;
686 - a symbol, in which case that symbol's function definition is called; or
687 - t, in which case the output is displayed in the echo area.
689 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
691 (Lisp_Object object
, Lisp_Object printcharfun
)
696 if (NILP (printcharfun
))
697 printcharfun
= Vstandard_output
;
701 print (object
, printcharfun
, 1);
708 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
709 doc
: /* Write CHARACTER to stderr.
710 You can call print while debugging emacs, and pass it this function
711 to make it write to the debugging output. */)
712 (Lisp_Object character
)
716 CHECK_NUMBER (character
);
717 ch
= XINT (character
);
718 if (ASCII_CHAR_P (ch
))
722 /* Send the output to a debugger (nothing happens if there isn't
724 if (print_output_debug_flag
)
726 char buf
[2] = {(char) XINT (character
), '\0'};
727 OutputDebugString (buf
);
733 unsigned char mbstr
[MAX_MULTIBYTE_LENGTH
];
734 ptrdiff_t len
= CHAR_STRING (ch
, mbstr
);
735 Lisp_Object encoded_ch
=
736 ENCODE_SYSTEM (make_multibyte_string ((char *) mbstr
, 1, len
));
738 fwrite (SSDATA (encoded_ch
), SBYTES (encoded_ch
), 1, stderr
);
740 if (print_output_debug_flag
)
741 OutputDebugString (SSDATA (encoded_ch
));
748 /* This function is never called. Its purpose is to prevent
749 print_output_debug_flag from being optimized away. */
751 extern void debug_output_compilation_hack (bool) EXTERNALLY_VISIBLE
;
753 debug_output_compilation_hack (bool x
)
755 print_output_debug_flag
= x
;
758 #if defined (GNU_LINUX)
760 /* This functionality is not vitally important in general, so we rely on
761 non-portable ability to use stderr as lvalue. */
763 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
765 static FILE *initial_stderr_stream
= NULL
;
767 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
769 "FDebug output file: \nP",
770 doc
: /* Redirect debugging output (stderr stream) to file FILE.
771 If FILE is nil, reset target to the initial stderr stream.
772 Optional arg APPEND non-nil (interactively, with prefix arg) means
773 append to existing target file. */)
774 (Lisp_Object file
, Lisp_Object append
)
776 if (initial_stderr_stream
!= NULL
)
782 stderr
= initial_stderr_stream
;
783 initial_stderr_stream
= NULL
;
787 file
= Fexpand_file_name (file
, Qnil
);
788 initial_stderr_stream
= stderr
;
789 stderr
= emacs_fopen (SSDATA (file
), NILP (append
) ? "w" : "a");
792 stderr
= initial_stderr_stream
;
793 initial_stderr_stream
= NULL
;
794 report_file_error ("Cannot open debugging output stream", file
);
799 #endif /* GNU_LINUX */
802 /* This is the interface for debugging printing. */
805 debug_print (Lisp_Object arg
)
807 Fprin1 (arg
, Qexternal_debugging_output
);
808 fprintf (stderr
, "\r\n");
811 void safe_debug_print (Lisp_Object
) EXTERNALLY_VISIBLE
;
813 safe_debug_print (Lisp_Object arg
)
815 int valid
= valid_lisp_object_p (arg
);
820 fprintf (stderr
, "#<%s_LISP_OBJECT 0x%08"pI
"x>\r\n",
821 !valid
? "INVALID" : "SOME",
826 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
828 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
829 See Info anchor `(elisp)Definition of signal' for some details on how this
830 error message is constructed. */)
833 struct buffer
*old
= current_buffer
;
837 /* If OBJ is (error STRING), just return STRING.
838 That is not only faster, it also avoids the need to allocate
839 space here when the error is due to memory full. */
840 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
841 && CONSP (XCDR (obj
))
842 && STRINGP (XCAR (XCDR (obj
)))
843 && NILP (XCDR (XCDR (obj
))))
844 return XCAR (XCDR (obj
));
846 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
848 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
849 value
= Fbuffer_string ();
853 set_buffer_internal (old
);
859 /* Print an error message for the error DATA onto Lisp output stream
860 STREAM (suitable for the print functions).
861 CONTEXT is a C string describing the context of the error.
862 CALLER is the Lisp function inside which the error was signaled. */
865 print_error_message (Lisp_Object data
, Lisp_Object stream
, const char *context
,
868 Lisp_Object errname
, errmsg
, file_error
, tail
;
872 write_string_1 (context
, -1, stream
);
874 /* If we know from where the error was signaled, show it in
876 if (!NILP (caller
) && SYMBOLP (caller
))
878 Lisp_Object cname
= SYMBOL_NAME (caller
);
879 ptrdiff_t cnamelen
= SBYTES (cname
);
881 char *name
= SAFE_ALLOCA (cnamelen
);
882 memcpy (name
, SDATA (cname
), cnamelen
);
883 message_dolog (name
, cnamelen
, 0, 0);
884 message_dolog (": ", 2, 0, 0);
888 errname
= Fcar (data
);
890 if (EQ (errname
, Qerror
))
895 errmsg
= Fcar (data
);
900 Lisp_Object error_conditions
= Fget (errname
, Qerror_conditions
);
901 errmsg
= Fget (errname
, Qerror_message
);
902 file_error
= Fmemq (Qfile_error
, error_conditions
);
905 /* Print an error message including the data items. */
907 tail
= Fcdr_safe (data
);
910 /* For file-error, make error message by concatenating
911 all the data items. They are all strings. */
912 if (!NILP (file_error
) && CONSP (tail
))
913 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
916 const char *sep
= ": ";
918 if (!STRINGP (errmsg
))
919 write_string_1 ("peculiar error", -1, stream
);
920 else if (SCHARS (errmsg
))
921 Fprinc (errmsg
, stream
);
925 for (; CONSP (tail
); tail
= XCDR (tail
), sep
= ", ")
930 write_string_1 (sep
, 2, stream
);
932 if (!NILP (file_error
)
933 || EQ (errname
, Qend_of_file
) || EQ (errname
, Quser_error
))
934 Fprinc (obj
, stream
);
936 Fprin1 (obj
, stream
);
946 * The buffer should be at least as large as the max string size of the
947 * largest float, printed in the biggest notation. This is undoubtedly
948 * 20d float_output_format, with the negative of the C-constant "HUGE"
951 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
953 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
954 * case of -1e307 in 20d float_output_format. What is one to do (short of
955 * re-writing _doprnt to be more sane)?
957 * Given the above, the buffer must be least FLOAT_TO_STRING_BUFSIZE bytes.
961 float_to_string (char *buf
, double data
)
967 /* Check for plus infinity in a way that won't lose
968 if there is no plus infinity. */
969 if (data
== data
/ 2 && data
> 1.0)
971 static char const infinity_string
[] = "1.0e+INF";
972 strcpy (buf
, infinity_string
);
973 return sizeof infinity_string
- 1;
975 /* Likewise for minus infinity. */
976 if (data
== data
/ 2 && data
< -1.0)
978 static char const minus_infinity_string
[] = "-1.0e+INF";
979 strcpy (buf
, minus_infinity_string
);
980 return sizeof minus_infinity_string
- 1;
982 /* Check for NaN in a way that won't fail if there are no NaNs. */
983 if (! (data
* 0.0 >= 0.0))
985 /* Prepend "-" if the NaN's sign bit is negative.
986 The sign bit of a double is the bit that is 1 in -0.0. */
987 static char const NaN_string
[] = "0.0e+NaN";
989 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
992 u_minus_zero
.d
= - 0.0;
993 for (i
= 0; i
< sizeof (double); i
++)
994 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
1001 strcpy (buf
+ negative
, NaN_string
);
1002 return negative
+ sizeof NaN_string
- 1;
1005 if (NILP (Vfloat_output_format
)
1006 || !STRINGP (Vfloat_output_format
))
1009 /* Generate the fewest number of digits that represent the
1010 floating point value without losing information. */
1011 len
= dtoastr (buf
, FLOAT_TO_STRING_BUFSIZE
- 2, 0, 0, data
);
1012 /* The decimal point must be printed, or the byte compiler can
1013 get confused (Bug#8033). */
1016 else /* oink oink */
1018 /* Check that the spec we have is fully valid.
1019 This means not only valid for printf,
1020 but meant for floats, and reasonable. */
1021 cp
= SSDATA (Vfloat_output_format
);
1030 /* Check the width specification. */
1032 if ('0' <= *cp
&& *cp
<= '9')
1037 width
= (width
* 10) + (*cp
++ - '0');
1038 if (DBL_DIG
< width
)
1041 while (*cp
>= '0' && *cp
<= '9');
1043 /* A precision of zero is valid only for %f. */
1044 if (width
== 0 && *cp
!= 'f')
1048 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1054 len
= sprintf (buf
, SSDATA (Vfloat_output_format
), data
);
1057 /* Make sure there is a decimal point with digit after, or an
1058 exponent, so that the value is readable as a float. But don't do
1059 this with "%.0f"; it's valid for that not to produce a decimal
1060 point. Note that width can be 0 only for %.0f. */
1063 for (cp
= buf
; *cp
; cp
++)
1064 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1067 if (*cp
== '.' && cp
[1] == 0)
1087 print (Lisp_Object obj
, Lisp_Object printcharfun
, bool escapeflag
)
1089 new_backquote_output
= 0;
1091 /* Reset print_number_index and Vprint_number_table only when
1092 the variable Vprint_continuous_numbering is nil. Otherwise,
1093 the values of these variables will be kept between several
1095 if (NILP (Vprint_continuous_numbering
)
1096 || NILP (Vprint_number_table
))
1098 print_number_index
= 0;
1099 Vprint_number_table
= Qnil
;
1102 /* Construct Vprint_number_table for print-gensym and print-circle. */
1103 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1105 /* Construct Vprint_number_table.
1106 This increments print_number_index for the objects added. */
1108 print_preprocess (obj
);
1110 if (HASH_TABLE_P (Vprint_number_table
))
1111 { /* Remove unnecessary objects, which appear only once in OBJ;
1112 that is, whose status is Qt. */
1113 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vprint_number_table
);
1116 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
1117 if (!NILP (HASH_HASH (h
, i
))
1118 && EQ (HASH_VALUE (h
, i
), Qt
))
1119 Fremhash (HASH_KEY (h
, i
), Vprint_number_table
);
1124 print_object (obj
, printcharfun
, escapeflag
);
1127 #define PRINT_CIRCLE_CANDIDATE_P(obj) \
1128 (STRINGP (obj) || CONSP (obj) \
1129 || (VECTORLIKEP (obj) \
1130 && (VECTORP (obj) || COMPILEDP (obj) \
1131 || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \
1132 || HASH_TABLE_P (obj) || FONTP (obj))) \
1133 || (! NILP (Vprint_gensym) \
1135 && !SYMBOL_INTERNED_P (obj)))
1137 /* Construct Vprint_number_table according to the structure of OBJ.
1138 OBJ itself and all its elements will be added to Vprint_number_table
1139 recursively if it is a list, vector, compiled function, char-table,
1140 string (its text properties will be traced), or a symbol that has
1141 no obarray (this is for the print-gensym feature).
1142 The status fields of Vprint_number_table mean whether each object appears
1143 more than once in OBJ: Qnil at the first time, and Qt after that. */
1145 print_preprocess (Lisp_Object obj
)
1150 Lisp_Object halftail
;
1152 /* Avoid infinite recursion for circular nested structure
1153 in the case where Vprint_circle is nil. */
1154 if (NILP (Vprint_circle
))
1156 /* Give up if we go so deep that print_object will get an error. */
1157 /* See similar code in print_object. */
1158 if (print_depth
>= PRINT_CIRCLE
)
1159 error ("Apparently circular structure being printed");
1161 for (i
= 0; i
< print_depth
; i
++)
1162 if (EQ (obj
, being_printed
[i
]))
1164 being_printed
[print_depth
] = obj
;
1171 if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1173 if (!HASH_TABLE_P (Vprint_number_table
))
1174 Vprint_number_table
= CALLN (Fmake_hash_table
, QCtest
, Qeq
);
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
= (SUB_CHAR_TABLE_P (obj
)
1229 ? SUB_CHAR_TABLE_OFFSET
: 0); i
< size
; i
++)
1230 print_preprocess (AREF (obj
, i
));
1231 if (HASH_TABLE_P (obj
))
1232 { /* For hash tables, the key_and_value slot is past
1233 `size' because it needs to be marked specially in case
1234 the table is weak. */
1235 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1236 print_preprocess (h
->key_and_value
);
1248 print_preprocess_string (INTERVAL interval
, Lisp_Object arg
)
1250 print_preprocess (interval
->plist
);
1253 static void print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
);
1255 #define PRINT_STRING_NON_CHARSET_FOUND 1
1256 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1258 /* Bitwise or of the above macros. */
1259 static int print_check_string_result
;
1262 print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
)
1266 if (NILP (interval
->plist
)
1267 || (print_check_string_result
== (PRINT_STRING_NON_CHARSET_FOUND
1268 | PRINT_STRING_UNSAFE_CHARSET_FOUND
)))
1270 for (val
= interval
->plist
; CONSP (val
) && ! EQ (XCAR (val
), Qcharset
);
1271 val
= XCDR (XCDR (val
)));
1274 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1277 if (! (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
))
1279 if (! EQ (val
, interval
->plist
)
1280 || CONSP (XCDR (XCDR (val
))))
1281 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1283 if (NILP (Vprint_charset_text_property
)
1284 || ! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1287 ptrdiff_t charpos
= interval
->position
;
1288 ptrdiff_t bytepos
= string_char_to_byte (string
, charpos
);
1289 Lisp_Object charset
;
1291 charset
= XCAR (XCDR (val
));
1292 for (i
= 0; i
< LENGTH (interval
); i
++)
1294 FETCH_STRING_CHAR_ADVANCE (c
, string
, charpos
, bytepos
);
1295 if (! ASCII_CHAR_P (c
)
1296 && ! EQ (CHARSET_NAME (CHAR_CHARSET (c
)), charset
))
1298 print_check_string_result
|= PRINT_STRING_UNSAFE_CHARSET_FOUND
;
1305 /* The value is (charset . nil). */
1306 static Lisp_Object print_prune_charset_plist
;
1309 print_prune_string_charset (Lisp_Object string
)
1311 print_check_string_result
= 0;
1312 traverse_intervals (string_intervals (string
), 0,
1313 print_check_string_charset_prop
, string
);
1314 if (! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1316 string
= Fcopy_sequence (string
);
1317 if (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
)
1319 if (NILP (print_prune_charset_plist
))
1320 print_prune_charset_plist
= list1 (Qcharset
);
1321 Fremove_text_properties (make_number (0),
1322 make_number (SCHARS (string
)),
1323 print_prune_charset_plist
, string
);
1326 Fset_text_properties (make_number (0), make_number (SCHARS (string
)),
1333 print_object (Lisp_Object obj
, Lisp_Object printcharfun
, bool escapeflag
)
1335 char buf
[max (sizeof "from..to..in " + 2 * INT_STRLEN_BOUND (EMACS_INT
),
1336 max (sizeof " . #" + INT_STRLEN_BOUND (printmax_t
),
1341 /* Detect circularities and truncate them. */
1342 if (NILP (Vprint_circle
))
1344 /* Simple but incomplete way. */
1347 /* See similar code in print_preprocess. */
1348 if (print_depth
>= PRINT_CIRCLE
)
1349 error ("Apparently circular structure being printed");
1351 for (i
= 0; i
< print_depth
; i
++)
1352 if (EQ (obj
, being_printed
[i
]))
1354 int len
= sprintf (buf
, "#%d", i
);
1355 strout (buf
, len
, len
, printcharfun
);
1358 being_printed
[print_depth
] = obj
;
1360 else if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1362 /* With the print-circle feature. */
1363 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1366 EMACS_INT n
= XINT (num
);
1368 { /* Add a prefix #n= if OBJ has not yet been printed;
1369 that is, its status field is nil. */
1370 int len
= sprintf (buf
, "#%"pI
"d=", -n
);
1371 strout (buf
, len
, len
, printcharfun
);
1372 /* OBJ is going to be printed. Remember that fact. */
1373 Fputhash (obj
, make_number (- n
), Vprint_number_table
);
1377 /* Just print #n# if OBJ has already been printed. */
1378 int len
= sprintf (buf
, "#%"pI
"d#", n
);
1379 strout (buf
, len
, len
, printcharfun
);
1387 switch (XTYPE (obj
))
1391 int len
= sprintf (buf
, "%"pI
"d", XINT (obj
));
1392 strout (buf
, len
, len
, printcharfun
);
1398 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
1399 int len
= float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1400 strout (pigbuf
, len
, len
, printcharfun
);
1406 print_string (obj
, printcharfun
);
1409 register ptrdiff_t i
, i_byte
;
1410 struct gcpro gcpro1
;
1411 ptrdiff_t size_byte
;
1412 /* 1 means we must ensure that the next character we output
1413 cannot be taken as part of a hex character escape. */
1414 bool need_nonhex
= 0;
1415 bool multibyte
= STRING_MULTIBYTE (obj
);
1419 if (! EQ (Vprint_charset_text_property
, Qt
))
1420 obj
= print_prune_string_charset (obj
);
1422 if (string_intervals (obj
))
1429 size_byte
= SBYTES (obj
);
1431 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1433 /* Here, we must convert each multi-byte form to the
1434 corresponding character code before handing it to PRINTCHAR. */
1437 FETCH_STRING_CHAR_ADVANCE (c
, obj
, i
, i_byte
);
1441 if (c
== '\n' && print_escape_newlines
)
1446 else if (c
== '\f' && print_escape_newlines
)
1452 && (CHAR_BYTE8_P (c
)
1453 || (! ASCII_CHAR_P (c
) && print_escape_multibyte
)))
1455 /* When multibyte is disabled,
1456 print multibyte string chars using hex escapes.
1457 For a char code that could be in a unibyte string,
1458 when found in a multibyte string, always use a hex escape
1459 so it reads back as multibyte. */
1463 if (CHAR_BYTE8_P (c
))
1464 len
= sprintf (outbuf
, "\\%03o", CHAR_TO_BYTE8 (c
));
1467 len
= sprintf (outbuf
, "\\x%04x", c
);
1470 strout (outbuf
, len
, len
, printcharfun
);
1472 else if (! multibyte
1473 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_CHAR_P (c
)
1474 && print_escape_nonascii
)
1476 /* When printing in a multibyte buffer
1477 or when explicitly requested,
1478 print single-byte non-ASCII string chars
1479 using octal escapes. */
1481 int len
= sprintf (outbuf
, "\\%03o", c
);
1482 strout (outbuf
, len
, len
, printcharfun
);
1486 /* If we just had a hex escape, and this character
1487 could be taken as part of it,
1488 output `\ ' to prevent that. */
1492 if ((c
>= 'a' && c
<= 'f')
1493 || (c
>= 'A' && c
<= 'F')
1494 || (c
>= '0' && c
<= '9'))
1495 strout ("\\ ", -1, -1, printcharfun
);
1498 if (c
== '\"' || c
== '\\')
1505 if (string_intervals (obj
))
1507 traverse_intervals (string_intervals (obj
),
1508 0, print_interval
, printcharfun
);
1519 unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1520 unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1522 ptrdiff_t i
, i_byte
;
1523 ptrdiff_t size_byte
;
1526 name
= SYMBOL_NAME (obj
);
1528 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1531 /* If symbol name begins with a digit, and ends with a digit,
1532 and contains nothing but digits and `e', it could be treated
1533 as a number. So set CONFUSING.
1535 Symbols that contain periods could also be taken as numbers,
1536 but periods are always escaped, so we don't have to worry
1538 else if (*p
>= '0' && *p
<= '9'
1539 && end
[-1] >= '0' && end
[-1] <= '9')
1541 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1542 /* Needed for \2e10. */
1543 || *p
== 'e' || *p
== 'E'))
1545 confusing
= (end
== p
);
1550 size_byte
= SBYTES (name
);
1552 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1557 else if (size_byte
== 0)
1564 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1566 /* Here, we must convert each multi-byte form to the
1567 corresponding character code before handing it to PRINTCHAR. */
1568 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1573 if (c
== '\"' || c
== '\\' || c
== '\''
1574 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1575 || c
== ',' || c
== '.' || c
== '`'
1576 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1578 PRINTCHAR ('\\'), confusing
= 0;
1586 /* If deeper than spec'd depth, print placeholder. */
1587 if (INTEGERP (Vprint_level
)
1588 && print_depth
> XINT (Vprint_level
))
1589 strout ("...", -1, -1, printcharfun
);
1590 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1591 && (EQ (XCAR (obj
), Qquote
)))
1594 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1596 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1597 && (EQ (XCAR (obj
), Qfunction
)))
1601 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1603 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1604 && ((EQ (XCAR (obj
), Qbackquote
))))
1606 print_object (XCAR (obj
), printcharfun
, 0);
1607 new_backquote_output
++;
1608 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1609 new_backquote_output
--;
1611 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1612 && new_backquote_output
1613 && ((EQ (XCAR (obj
), Qbackquote
)
1614 || EQ (XCAR (obj
), Qcomma
)
1615 || EQ (XCAR (obj
), Qcomma_at
)
1616 || EQ (XCAR (obj
), Qcomma_dot
))))
1618 print_object (XCAR (obj
), printcharfun
, 0);
1619 new_backquote_output
--;
1620 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1621 new_backquote_output
++;
1628 printmax_t i
, print_length
;
1629 Lisp_Object halftail
= obj
;
1631 /* Negative values of print-length are invalid in CL.
1632 Treat them like nil, as CMUCL does. */
1633 if (NATNUMP (Vprint_length
))
1634 print_length
= XFASTINT (Vprint_length
);
1636 print_length
= TYPE_MAXIMUM (printmax_t
);
1641 /* Detect circular list. */
1642 if (NILP (Vprint_circle
))
1644 /* Simple but incomplete way. */
1645 if (i
!= 0 && EQ (obj
, halftail
))
1647 int len
= sprintf (buf
, " . #%"pMd
, i
/ 2);
1648 strout (buf
, len
, len
, printcharfun
);
1654 /* With the print-circle feature. */
1657 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1660 strout (" . ", 3, 3, printcharfun
);
1661 print_object (obj
, printcharfun
, escapeflag
);
1670 if (print_length
<= i
)
1672 strout ("...", 3, 3, printcharfun
);
1677 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1681 halftail
= XCDR (halftail
);
1685 /* OBJ non-nil here means it's the end of a dotted list. */
1688 strout (" . ", 3, 3, printcharfun
);
1689 print_object (obj
, printcharfun
, escapeflag
);
1697 case Lisp_Vectorlike
:
1702 strout ("#<process ", -1, -1, printcharfun
);
1703 print_string (XPROCESS (obj
)->name
, printcharfun
);
1707 print_string (XPROCESS (obj
)->name
, printcharfun
);
1709 else if (BOOL_VECTOR_P (obj
))
1714 struct gcpro gcpro1
;
1715 EMACS_INT size
= bool_vector_size (obj
);
1716 ptrdiff_t size_in_chars
= bool_vector_bytes (size
);
1717 ptrdiff_t real_size_in_chars
= size_in_chars
;
1722 len
= sprintf (buf
, "%"pI
"d", size
);
1723 strout (buf
, len
, len
, printcharfun
);
1726 /* Don't print more characters than the specified maximum.
1727 Negative values of print-length are invalid. Treat them
1728 like a print-length of nil. */
1729 if (NATNUMP (Vprint_length
)
1730 && XFASTINT (Vprint_length
) < size_in_chars
)
1731 size_in_chars
= XFASTINT (Vprint_length
);
1733 for (i
= 0; i
< size_in_chars
; i
++)
1736 c
= bool_vector_uchar_data (obj
)[i
];
1737 if (c
== '\n' && print_escape_newlines
)
1742 else if (c
== '\f' && print_escape_newlines
)
1747 else if (c
> '\177')
1749 /* Use octal escapes to avoid encoding issues. */
1751 PRINTCHAR ('0' + ((c
>> 6) & 3));
1752 PRINTCHAR ('0' + ((c
>> 3) & 7));
1753 PRINTCHAR ('0' + (c
& 7));
1757 if (c
== '\"' || c
== '\\')
1763 if (size_in_chars
< real_size_in_chars
)
1764 strout (" ...", 4, 4, printcharfun
);
1769 else if (SUBRP (obj
))
1771 strout ("#<subr ", -1, -1, printcharfun
);
1772 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
);
1775 else if (WINDOWP (obj
))
1777 int len
= sprintf (buf
, "#<window %"pI
"d",
1778 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 && XSUB_CHAR_TABLE (obj
)->depth
== 3)
1972 if (SUB_CHAR_TABLE_P (obj
))
1974 size
&= PSEUDOVECTOR_SIZE_MASK
;
1976 if (size
& PSEUDOVECTOR_FLAG
)
1981 int i
, idx
= SUB_CHAR_TABLE_P (obj
) ? SUB_CHAR_TABLE_OFFSET
: 0;
1982 register Lisp_Object tem
;
1983 ptrdiff_t real_size
= size
;
1985 /* For a sub char-table, print heading non-Lisp data first. */
1986 if (SUB_CHAR_TABLE_P (obj
))
1988 i
= sprintf (buf
, "%d %d", XSUB_CHAR_TABLE (obj
)->depth
,
1989 XSUB_CHAR_TABLE (obj
)->min_char
);
1990 strout (buf
, i
, i
, printcharfun
);
1993 /* Don't print more elements than the specified maximum. */
1994 if (NATNUMP (Vprint_length
)
1995 && XFASTINT (Vprint_length
) < size
)
1996 size
= XFASTINT (Vprint_length
);
1998 for (i
= idx
; i
< size
; i
++)
2000 if (i
) PRINTCHAR (' ');
2001 tem
= AREF (obj
, i
);
2002 print_object (tem
, printcharfun
, escapeflag
);
2004 if (size
< real_size
)
2005 strout (" ...", 4, 4, printcharfun
);
2012 switch (XMISCTYPE (obj
))
2014 case Lisp_Misc_Marker
:
2015 strout ("#<marker ", -1, -1, printcharfun
);
2016 /* Do you think this is necessary? */
2017 if (XMARKER (obj
)->insertion_type
!= 0)
2018 strout ("(moves after insertion) ", -1, -1, printcharfun
);
2019 if (! XMARKER (obj
)->buffer
)
2020 strout ("in no buffer", -1, -1, printcharfun
);
2023 int len
= sprintf (buf
, "at %"pD
"d", marker_position (obj
));
2024 strout (buf
, len
, len
, printcharfun
);
2025 strout (" in ", -1, -1, printcharfun
);
2026 print_string (BVAR (XMARKER (obj
)->buffer
, name
), printcharfun
);
2031 case Lisp_Misc_Overlay
:
2032 strout ("#<overlay ", -1, -1, printcharfun
);
2033 if (! XMARKER (OVERLAY_START (obj
))->buffer
)
2034 strout ("in no buffer", -1, -1, printcharfun
);
2037 int len
= sprintf (buf
, "from %"pD
"d to %"pD
"d in ",
2038 marker_position (OVERLAY_START (obj
)),
2039 marker_position (OVERLAY_END (obj
)));
2040 strout (buf
, len
, len
, printcharfun
);
2041 print_string (BVAR (XMARKER (OVERLAY_START (obj
))->buffer
, name
),
2047 case Lisp_Misc_Finalizer
:
2048 strout ("#<finalizer", -1, -1, printcharfun
);
2049 if (NILP (XFINALIZER (obj
)->function
))
2050 strout (" used", -1, -1, printcharfun
);
2051 strout (">", -1, -1, printcharfun
);
2054 /* Remaining cases shouldn't happen in normal usage, but let's
2055 print them anyway for the benefit of the debugger. */
2057 case Lisp_Misc_Free
:
2058 strout ("#<misc free cell>", -1, -1, printcharfun
);
2061 case Lisp_Misc_Save_Value
:
2064 struct Lisp_Save_Value
*v
= XSAVE_VALUE (obj
);
2066 strout ("#<save-value ", -1, -1, printcharfun
);
2068 if (v
->save_type
== SAVE_TYPE_MEMORY
)
2070 ptrdiff_t amount
= v
->data
[1].integer
;
2074 /* valid_lisp_object_p is reliable, so try to print up
2075 to 8 saved objects. This code is rarely used, so
2076 it's OK that valid_lisp_object_p is slow. */
2078 int limit
= min (amount
, 8);
2079 Lisp_Object
*area
= v
->data
[0].pointer
;
2081 i
= sprintf (buf
, "with %"pD
"d objects", amount
);
2082 strout (buf
, i
, i
, printcharfun
);
2084 for (i
= 0; i
< limit
; i
++)
2086 Lisp_Object maybe
= area
[i
];
2087 int valid
= valid_lisp_object_p (maybe
);
2092 print_object (maybe
, printcharfun
, escapeflag
);
2095 strout (valid
? " <some>" : " <invalid>",
2096 -1, -1, printcharfun
);
2098 if (i
== limit
&& i
< amount
)
2099 strout (" ...", 4, 4, printcharfun
);
2101 #else /* not GC_MARK_STACK */
2103 /* There is no reliable way to determine whether the objects
2104 are initialized, so do not try to print them. */
2106 i
= sprintf (buf
, "with %"pD
"d objects", amount
);
2107 strout (buf
, i
, i
, printcharfun
);
2109 #endif /* GC_MARK_STACK */
2113 /* Print each slot according to its type. */
2115 for (index
= 0; index
< SAVE_VALUE_SLOTS
; index
++)
2120 switch (save_type (v
, index
))
2123 i
= sprintf (buf
, "<unused>");
2127 i
= sprintf (buf
, "<pointer %p>",
2128 v
->data
[index
].pointer
);
2131 case SAVE_FUNCPOINTER
:
2132 i
= sprintf (buf
, "<funcpointer %p>",
2133 ((void *) (intptr_t)
2134 v
->data
[index
].funcpointer
));
2138 i
= sprintf (buf
, "<integer %"pD
"d>",
2139 v
->data
[index
].integer
);
2143 print_object (v
->data
[index
].object
, printcharfun
,
2151 strout (buf
, i
, i
, printcharfun
);
2167 /* We're in trouble if this happens!
2168 Probably should just emacs_abort (). */
2169 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
);
2171 len
= sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2172 else if (VECTORLIKEP (obj
))
2173 len
= sprintf (buf
, "(PVEC 0x%08"pD
"x)", ASIZE (obj
));
2175 len
= sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2176 strout (buf
, len
, len
, printcharfun
);
2177 strout (" Save your buffers immediately and please report this bug>",
2178 -1, -1, printcharfun
);
2186 /* Print a description of INTERVAL using PRINTCHARFUN.
2187 This is part of printing a string that has text properties. */
2190 print_interval (INTERVAL interval
, Lisp_Object printcharfun
)
2192 if (NILP (interval
->plist
))
2195 print_object (make_number (interval
->position
), printcharfun
, 1);
2197 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2200 print_object (interval
->plist
, printcharfun
, 1);
2203 /* Initialize debug_print stuff early to have it working from the very
2207 init_print_once (void)
2209 /* The subroutine object for external-debugging-output is kept here
2210 for the convenience of the debugger. */
2211 DEFSYM (Qexternal_debugging_output
, "external-debugging-output");
2213 defsubr (&Sexternal_debugging_output
);
2217 syms_of_print (void)
2219 DEFSYM (Qtemp_buffer_setup_hook
, "temp-buffer-setup-hook");
2221 DEFVAR_LISP ("standard-output", Vstandard_output
,
2222 doc
: /* Output stream `print' uses by default for outputting a character.
2223 This may be any function of one argument.
2224 It may also be a buffer (output is inserted before point)
2225 or a marker (output is inserted and the marker is advanced)
2226 or the symbol t (output appears in the echo area). */);
2227 Vstandard_output
= Qt
;
2228 DEFSYM (Qstandard_output
, "standard-output");
2230 DEFVAR_LISP ("float-output-format", Vfloat_output_format
,
2231 doc
: /* The format descriptor string used to print floats.
2232 This is a %-spec like those accepted by `printf' in C,
2233 but with some restrictions. It must start with the two characters `%.'.
2234 After that comes an integer precision specification,
2235 and then a letter which controls the format.
2236 The letters allowed are `e', `f' and `g'.
2237 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2238 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2239 Use `g' to choose the shorter of those two formats for the number at hand.
2240 The precision in any of these cases is the number of digits following
2241 the decimal point. With `f', a precision of 0 means to omit the
2242 decimal point. 0 is not allowed with `e' or `g'.
2244 A value of nil means to use the shortest notation
2245 that represents the number without losing information. */);
2246 Vfloat_output_format
= Qnil
;
2247 DEFSYM (Qfloat_output_format
, "float-output-format");
2249 DEFVAR_LISP ("print-length", Vprint_length
,
2250 doc
: /* Maximum length of list to print before abbreviating.
2251 A value of nil means no limit. See also `eval-expression-print-length'. */);
2252 Vprint_length
= Qnil
;
2254 DEFVAR_LISP ("print-level", Vprint_level
,
2255 doc
: /* Maximum depth of list nesting to print before abbreviating.
2256 A value of nil means no limit. See also `eval-expression-print-level'. */);
2257 Vprint_level
= Qnil
;
2259 DEFVAR_BOOL ("print-escape-newlines", print_escape_newlines
,
2260 doc
: /* Non-nil means print newlines in strings as `\\n'.
2261 Also print formfeeds as `\\f'. */);
2262 print_escape_newlines
= 0;
2264 DEFVAR_BOOL ("print-escape-nonascii", print_escape_nonascii
,
2265 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2266 \(OOO is the octal representation of the character code.)
2267 Only single-byte characters are affected, and only in `prin1'.
2268 When the output goes in a multibyte buffer, this feature is
2269 enabled regardless of the value of the variable. */);
2270 print_escape_nonascii
= 0;
2272 DEFVAR_BOOL ("print-escape-multibyte", print_escape_multibyte
,
2273 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2274 \(XXXX is the hex representation of the character code.)
2275 This affects only `prin1'. */);
2276 print_escape_multibyte
= 0;
2278 DEFVAR_BOOL ("print-quoted", print_quoted
,
2279 doc
: /* Non-nil means print quoted forms with reader syntax.
2280 I.e., (quote foo) prints as 'foo, (function foo) as #'foo. */);
2283 DEFVAR_LISP ("print-gensym", Vprint_gensym
,
2284 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2285 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2286 When the uninterned symbol appears within a recursive data structure,
2287 and the symbol appears more than once, in addition use the #N# and #N=
2288 constructs as needed, so that multiple references to the same symbol are
2289 shared once again when the text is read back. */);
2290 Vprint_gensym
= Qnil
;
2292 DEFVAR_LISP ("print-circle", Vprint_circle
,
2293 doc
: /* Non-nil means print recursive structures using #N= and #N# syntax.
2294 If nil, printing proceeds recursively and may lead to
2295 `max-lisp-eval-depth' being exceeded or an error may occur:
2296 \"Apparently circular structure being printed.\" Also see
2297 `print-length' and `print-level'.
2298 If non-nil, shared substructures anywhere in the structure are printed
2299 with `#N=' before the first occurrence (in the order of the print
2300 representation) and `#N#' in place of each subsequent occurrence,
2301 where N is a positive decimal integer. */);
2302 Vprint_circle
= Qnil
;
2304 DEFVAR_LISP ("print-continuous-numbering", Vprint_continuous_numbering
,
2305 doc
: /* Non-nil means number continuously across print calls.
2306 This affects the numbers printed for #N= labels and #M# references.
2307 See also `print-circle', `print-gensym', and `print-number-table'.
2308 This variable should not be set with `setq'; bind it with a `let' instead. */);
2309 Vprint_continuous_numbering
= Qnil
;
2311 DEFVAR_LISP ("print-number-table", Vprint_number_table
,
2312 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2313 The Lisp printer uses this vector to detect Lisp objects referenced more
2316 When you bind `print-continuous-numbering' to t, you should probably
2317 also bind `print-number-table' to nil. This ensures that the value of
2318 `print-number-table' can be garbage-collected once the printing is
2319 done. If all elements of `print-number-table' are nil, it means that
2320 the printing done so far has not found any shared structure or objects
2321 that need to be recorded in the table. */);
2322 Vprint_number_table
= Qnil
;
2324 DEFVAR_LISP ("print-charset-text-property", Vprint_charset_text_property
,
2325 doc
: /* A flag to control printing of `charset' text property on printing a string.
2326 The value must be nil, t, or `default'.
2328 If the value is nil, don't print the text property `charset'.
2330 If the value is t, always print the text property `charset'.
2332 If the value is `default', print the text property `charset' only when
2333 the value is different from what is guessed in the current charset
2335 Vprint_charset_text_property
= Qdefault
;
2337 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2338 staticpro (&Vprin1_to_string_buffer
);
2341 defsubr (&Sprin1_to_string
);
2342 defsubr (&Serror_message_string
);
2346 defsubr (&Swrite_char
);
2347 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2348 defsubr (&Sredirect_debugging_output
);
2351 DEFSYM (Qprint_escape_newlines
, "print-escape-newlines");
2352 DEFSYM (Qprint_escape_multibyte
, "print-escape-multibyte");
2353 DEFSYM (Qprint_escape_nonascii
, "print-escape-nonascii");
2355 print_prune_charset_plist
= Qnil
;
2356 staticpro (&print_prune_charset_plist
);