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 Lisp_Object Qstandard_output
;
45 static Lisp_Object Qtemp_buffer_setup_hook
;
47 /* These are used to print like we read. */
49 static Lisp_Object Qfloat_output_format
;
54 /* Avoid actual stack overflow in print. */
55 static ptrdiff_t print_depth
;
57 /* Level of nesting inside outputting backquote in new style. */
58 static ptrdiff_t new_backquote_output
;
60 /* Detect most circularities to print finite output. */
61 #define PRINT_CIRCLE 200
62 static Lisp_Object being_printed
[PRINT_CIRCLE
];
64 /* Last char printed to stdout by printchar. */
65 static unsigned int printchar_stdout_last
;
67 /* When printing into a buffer, first we put the text in this
68 block, then insert it all at once. */
69 static char *print_buffer
;
71 /* Size allocated in print_buffer. */
72 static ptrdiff_t print_buffer_size
;
73 /* Chars stored in print_buffer. */
74 static ptrdiff_t print_buffer_pos
;
75 /* Bytes stored in print_buffer. */
76 static ptrdiff_t print_buffer_pos_byte
;
78 Lisp_Object Qprint_escape_newlines
;
79 static Lisp_Object Qprint_escape_multibyte
, Qprint_escape_nonascii
;
81 /* Vprint_number_table is a table, that keeps objects that are going to
82 be printed, to allow use of #n= and #n# to express sharing.
83 For any given object, the table can give the following values:
84 t the object will be printed only once.
85 -N the object will be printed several times and will take number N.
86 N the object has been printed so we can refer to it as #N#.
87 print_number_index holds the largest N already used.
88 N has to be striclty larger than 0 since we need to distinguish -N. */
89 static ptrdiff_t print_number_index
;
90 static void print_interval (INTERVAL interval
, Lisp_Object printcharfun
);
92 /* GDB resets this to zero on W32 to disable OutputDebugString calls. */
93 bool print_output_debug_flag EXTERNALLY_VISIBLE
= 1;
96 /* Low level output routines for characters and strings. */
98 /* Lisp functions to do output using a stream
99 must have the stream in a variable called printcharfun
100 and must start with PRINTPREPARE, end with PRINTFINISH,
101 and use PRINTDECLARE to declare common variables.
102 Use PRINTCHAR to output one character,
103 or call strout to output a block of characters. */
105 #define PRINTDECLARE \
106 struct buffer *old = current_buffer; \
107 ptrdiff_t old_point = -1, start_point = -1; \
108 ptrdiff_t old_point_byte = -1, start_point_byte = -1; \
109 ptrdiff_t specpdl_count = SPECPDL_INDEX (); \
110 bool free_print_buffer = 0; \
112 = !NILP (BVAR (current_buffer, enable_multibyte_characters)); \
115 #define PRINTPREPARE \
116 original = printcharfun; \
117 if (NILP (printcharfun)) printcharfun = Qt; \
118 if (BUFFERP (printcharfun)) \
120 if (XBUFFER (printcharfun) != current_buffer) \
121 Fset_buffer (printcharfun); \
122 printcharfun = Qnil; \
124 if (MARKERP (printcharfun)) \
126 ptrdiff_t marker_pos; \
127 if (! XMARKER (printcharfun)->buffer) \
128 error ("Marker does not point anywhere"); \
129 if (XMARKER (printcharfun)->buffer != current_buffer) \
130 set_buffer_internal (XMARKER (printcharfun)->buffer); \
131 marker_pos = marker_position (printcharfun); \
132 if (marker_pos < BEGV || marker_pos > ZV) \
133 signal_error ("Marker is outside the accessible " \
134 "part of the buffer", printcharfun); \
136 old_point_byte = PT_BYTE; \
137 SET_PT_BOTH (marker_pos, \
138 marker_byte_position (printcharfun)); \
140 start_point_byte = PT_BYTE; \
141 printcharfun = Qnil; \
143 if (NILP (printcharfun)) \
145 Lisp_Object string; \
146 if (NILP (BVAR (current_buffer, enable_multibyte_characters)) \
147 && ! print_escape_multibyte) \
148 specbind (Qprint_escape_multibyte, Qt); \
149 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)) \
150 && ! print_escape_nonascii) \
151 specbind (Qprint_escape_nonascii, Qt); \
152 if (print_buffer != 0) \
154 string = make_string_from_bytes (print_buffer, \
156 print_buffer_pos_byte); \
157 record_unwind_protect (print_unwind, string); \
161 int new_size = 1000; \
162 print_buffer = xmalloc (new_size); \
163 print_buffer_size = new_size; \
164 free_print_buffer = 1; \
166 print_buffer_pos = 0; \
167 print_buffer_pos_byte = 0; \
169 if (EQ (printcharfun, Qt) && ! noninteractive) \
170 setup_echo_area_for_printing (multibyte);
172 #define PRINTFINISH \
173 if (NILP (printcharfun)) \
175 if (print_buffer_pos != print_buffer_pos_byte \
176 && NILP (BVAR (current_buffer, enable_multibyte_characters)))\
179 unsigned char *temp = SAFE_ALLOCA (print_buffer_pos + 1); \
180 copy_text ((unsigned char *) print_buffer, temp, \
181 print_buffer_pos_byte, 1, 0); \
182 insert_1_both ((char *) temp, print_buffer_pos, \
183 print_buffer_pos, 0, 1, 0); \
187 insert_1_both (print_buffer, print_buffer_pos, \
188 print_buffer_pos_byte, 0, 1, 0); \
189 signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
191 if (free_print_buffer) \
193 xfree (print_buffer); \
196 unbind_to (specpdl_count, Qnil); \
197 if (MARKERP (original)) \
198 set_marker_both (original, Qnil, PT, PT_BYTE); \
199 if (old_point >= 0) \
200 SET_PT_BOTH (old_point + (old_point >= start_point \
201 ? PT - start_point : 0), \
202 old_point_byte + (old_point_byte >= start_point_byte \
203 ? PT_BYTE - start_point_byte : 0)); \
204 set_buffer_internal (old);
206 #define PRINTCHAR(ch) printchar (ch, printcharfun)
208 /* This is used to restore the saved contents of print_buffer
209 when there is a recursive call to print. */
212 print_unwind (Lisp_Object saved_text
)
214 memcpy (print_buffer
, SDATA (saved_text
), SCHARS (saved_text
));
218 /* Print character CH using method FUN. FUN nil means print to
219 print_buffer. FUN t means print to echo area or stdout if
220 non-interactive. If FUN is neither nil nor t, call FUN with CH as
224 printchar (unsigned int ch
, Lisp_Object fun
)
226 if (!NILP (fun
) && !EQ (fun
, Qt
))
227 call1 (fun
, make_number (ch
));
230 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
231 int len
= CHAR_STRING (ch
, str
);
237 ptrdiff_t incr
= len
- (print_buffer_size
- print_buffer_pos_byte
);
239 print_buffer
= xpalloc (print_buffer
, &print_buffer_size
,
241 memcpy (print_buffer
+ print_buffer_pos_byte
, str
, len
);
242 print_buffer_pos
+= 1;
243 print_buffer_pos_byte
+= len
;
245 else if (noninteractive
)
247 printchar_stdout_last
= ch
;
248 fwrite (str
, 1, len
, stdout
);
249 noninteractive_need_newline
= 1;
254 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
256 setup_echo_area_for_printing (multibyte_p
);
258 message_dolog ((char *) str
, len
, 0, multibyte_p
);
264 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
265 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
266 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
267 print_buffer. PRINTCHARFUN t means output to the echo area or to
268 stdout if non-interactive. If neither nil nor t, call Lisp
269 function PRINTCHARFUN for each character printed. MULTIBYTE
270 non-zero means PTR contains multibyte characters.
272 In the case where PRINTCHARFUN is nil, it is safe for PTR to point
273 to data in a Lisp string. Otherwise that is not safe. */
276 strout (const char *ptr
, ptrdiff_t size
, ptrdiff_t size_byte
,
277 Lisp_Object printcharfun
)
280 size_byte
= size
= strlen (ptr
);
282 if (NILP (printcharfun
))
284 ptrdiff_t incr
= size_byte
- (print_buffer_size
- print_buffer_pos_byte
);
286 print_buffer
= xpalloc (print_buffer
, &print_buffer_size
, incr
, -1, 1);
287 memcpy (print_buffer
+ print_buffer_pos_byte
, ptr
, size_byte
);
288 print_buffer_pos
+= size
;
289 print_buffer_pos_byte
+= size_byte
;
291 else if (noninteractive
&& EQ (printcharfun
, Qt
))
293 fwrite (ptr
, 1, size_byte
, stdout
);
294 noninteractive_need_newline
= 1;
296 else if (EQ (printcharfun
, Qt
))
298 /* Output to echo area. We're trying to avoid a little overhead
299 here, that's the reason we don't call printchar to do the
303 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
305 setup_echo_area_for_printing (multibyte_p
);
306 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
308 if (size
== size_byte
)
310 for (i
= 0; i
< size
; ++i
)
311 insert_char ((unsigned char) *ptr
++);
316 for (i
= 0; i
< size_byte
; i
+= len
)
318 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
326 /* PRINTCHARFUN is a Lisp function. */
329 if (size
== size_byte
)
331 while (i
< size_byte
)
339 while (i
< size_byte
)
341 /* Here, we must convert each multi-byte form to the
342 corresponding character code before handing it to
345 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
354 /* Print the contents of a string STRING using PRINTCHARFUN.
355 It isn't safe to use strout in many cases,
356 because printing one char can relocate. */
359 print_string (Lisp_Object string
, Lisp_Object printcharfun
)
361 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
365 if (print_escape_nonascii
)
366 string
= string_escape_byte8 (string
);
368 if (STRING_MULTIBYTE (string
))
369 chars
= SCHARS (string
);
370 else if (! print_escape_nonascii
371 && (EQ (printcharfun
, Qt
)
372 ? ! NILP (BVAR (&buffer_defaults
, enable_multibyte_characters
))
373 : ! NILP (BVAR (current_buffer
, enable_multibyte_characters
))))
375 /* If unibyte string STRING contains 8-bit codes, we must
376 convert STRING to a multibyte string containing the same
381 chars
= SBYTES (string
);
382 bytes
= count_size_as_multibyte (SDATA (string
), chars
);
385 newstr
= make_uninit_multibyte_string (chars
, bytes
);
386 memcpy (SDATA (newstr
), SDATA (string
), chars
);
387 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
392 chars
= SBYTES (string
);
394 if (EQ (printcharfun
, Qt
))
396 /* Output to echo area. */
397 ptrdiff_t nbytes
= SBYTES (string
);
399 /* Copy the string contents so that relocation of STRING by
400 GC does not cause trouble. */
402 char *buffer
= SAFE_ALLOCA (nbytes
);
403 memcpy (buffer
, SDATA (string
), nbytes
);
405 strout (buffer
, chars
, nbytes
, printcharfun
);
410 /* No need to copy, since output to print_buffer can't GC. */
411 strout (SSDATA (string
), chars
, SBYTES (string
), printcharfun
);
415 /* Otherwise, string may be relocated by printing one char.
416 So re-fetch the string address for each character. */
418 ptrdiff_t size
= SCHARS (string
);
419 ptrdiff_t size_byte
= SBYTES (string
);
422 if (size
== size_byte
)
423 for (i
= 0; i
< size
; i
++)
424 PRINTCHAR (SREF (string
, i
));
426 for (i
= 0; i
< size_byte
; )
428 /* Here, we must convert each multi-byte form to the
429 corresponding character code before handing it to PRINTCHAR. */
431 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
, len
);
439 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
440 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
441 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
442 (Lisp_Object character
, Lisp_Object printcharfun
)
446 if (NILP (printcharfun
))
447 printcharfun
= Vstandard_output
;
448 CHECK_NUMBER (character
);
450 PRINTCHAR (XINT (character
));
455 /* Used from outside of print.c to print a block of SIZE
456 single-byte chars at DATA on the default output stream.
457 Do not use this on the contents of a Lisp string. */
460 write_string (const char *data
, int size
)
463 Lisp_Object printcharfun
;
465 printcharfun
= Vstandard_output
;
468 strout (data
, size
, size
, printcharfun
);
472 /* Used to print a block of SIZE single-byte chars at DATA on a
473 specified stream PRINTCHARFUN.
474 Do not use this on the contents of a Lisp string. */
477 write_string_1 (const char *data
, int size
, Lisp_Object printcharfun
)
482 strout (data
, size
, size
, printcharfun
);
488 temp_output_buffer_setup (const char *bufname
)
490 ptrdiff_t count
= SPECPDL_INDEX ();
491 register struct buffer
*old
= current_buffer
;
492 register Lisp_Object buf
;
494 record_unwind_current_buffer ();
496 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
498 Fkill_all_local_variables ();
499 delete_all_overlays (current_buffer
);
500 bset_directory (current_buffer
, BVAR (old
, directory
));
501 bset_read_only (current_buffer
, Qnil
);
502 bset_filename (current_buffer
, Qnil
);
503 bset_undo_list (current_buffer
, Qt
);
504 eassert (current_buffer
->overlays_before
== NULL
);
505 eassert (current_buffer
->overlays_after
== NULL
);
506 bset_enable_multibyte_characters
507 (current_buffer
, BVAR (&buffer_defaults
, enable_multibyte_characters
));
508 specbind (Qinhibit_read_only
, Qt
);
509 specbind (Qinhibit_modification_hooks
, Qt
);
511 XSETBUFFER (buf
, current_buffer
);
513 Frun_hooks (1, &Qtemp_buffer_setup_hook
);
515 unbind_to (count
, Qnil
);
517 specbind (Qstandard_output
, buf
);
520 static void print (Lisp_Object
, Lisp_Object
, bool);
521 static void print_preprocess (Lisp_Object
);
522 static void print_preprocess_string (INTERVAL
, Lisp_Object
);
523 static void print_object (Lisp_Object
, Lisp_Object
, bool);
525 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 2, 0,
526 doc
: /* Output a newline to stream PRINTCHARFUN.
527 If ENSURE is non-nil only output a newline if not already at the
528 beginning of a line. Value is non-nil if a newline is printed.
529 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
530 (Lisp_Object printcharfun
, Lisp_Object ensure
)
532 Lisp_Object val
= Qnil
;
535 if (NILP (printcharfun
))
536 printcharfun
= Vstandard_output
;
541 /* Difficult to check if at line beginning so abort. */
542 else if (FUNCTIONP (printcharfun
))
543 signal_error ("Unsupported function argument", printcharfun
);
544 else if (noninteractive
&& !NILP (printcharfun
))
545 val
= printchar_stdout_last
== 10 ? Qnil
: Qt
;
546 else if (NILP (Fbolp ()))
549 if (!NILP (val
)) PRINTCHAR ('\n');
554 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
555 doc
: /* Output the printed representation of OBJECT, any Lisp object.
556 Quoting characters are printed when needed to make output that `read'
557 can handle, whenever this is possible. For complex objects, the behavior
558 is controlled by `print-level' and `print-length', which see.
560 OBJECT is any of the Lisp data types: a number, a string, a symbol,
561 a list, a buffer, a window, a frame, etc.
563 A printed representation of an object is text which describes that object.
565 Optional argument PRINTCHARFUN is the output stream, which can be one
568 - a buffer, in which case output is inserted into that buffer at point;
569 - a marker, in which case output is inserted at marker's position;
570 - a function, in which case that function is called once for each
571 character of OBJECT's printed representation;
572 - a symbol, in which case that symbol's function definition is called; or
573 - t, in which case the output is displayed in the echo area.
575 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
577 (Lisp_Object object
, Lisp_Object printcharfun
)
581 if (NILP (printcharfun
))
582 printcharfun
= Vstandard_output
;
584 print (object
, printcharfun
, 1);
589 /* a buffer which is used to hold output being built by prin1-to-string */
590 Lisp_Object Vprin1_to_string_buffer
;
592 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
593 doc
: /* Return a string containing the printed representation of OBJECT.
594 OBJECT can be any Lisp object. This function outputs quoting characters
595 when necessary to make output that `read' can handle, whenever possible,
596 unless the optional second argument NOESCAPE is non-nil. For complex objects,
597 the behavior is controlled by `print-level' and `print-length', which see.
599 OBJECT is any of the Lisp data types: a number, a string, a symbol,
600 a list, a buffer, a window, a frame, etc.
602 A printed representation of an object is text which describes that object. */)
603 (Lisp_Object object
, Lisp_Object noescape
)
605 Lisp_Object printcharfun
;
606 bool prev_abort_on_gc
;
607 Lisp_Object save_deactivate_mark
;
608 ptrdiff_t count
= SPECPDL_INDEX ();
609 struct buffer
*previous
;
611 specbind (Qinhibit_modification_hooks
, Qt
);
616 /* Save and restore this--we are altering a buffer
617 but we don't want to deactivate the mark just for that.
618 No need for specbind, since errors deactivate the mark. */
619 save_deactivate_mark
= Vdeactivate_mark
;
620 prev_abort_on_gc
= abort_on_gc
;
623 printcharfun
= Vprin1_to_string_buffer
;
625 print (object
, printcharfun
, NILP (noescape
));
626 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINISH */
630 previous
= current_buffer
;
631 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
632 object
= Fbuffer_string ();
633 if (SBYTES (object
) == SCHARS (object
))
634 STRING_SET_UNIBYTE (object
);
636 /* Note that this won't make prepare_to_modify_buffer call
637 ask-user-about-supersession-threat because this buffer
638 does not visit a file. */
640 set_buffer_internal (previous
);
642 Vdeactivate_mark
= save_deactivate_mark
;
644 abort_on_gc
= prev_abort_on_gc
;
645 return unbind_to (count
, object
);
648 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
649 doc
: /* Output the printed representation of OBJECT, any Lisp object.
650 No quoting characters are used; no delimiters are printed around
651 the contents of strings.
653 OBJECT is any of the Lisp data types: a number, a string, a symbol,
654 a list, a buffer, a window, a frame, etc.
656 A printed representation of an object is text which describes that object.
658 Optional argument PRINTCHARFUN is the output stream, which can be one
661 - a buffer, in which case output is inserted into that buffer at point;
662 - a marker, in which case output is inserted at marker's position;
663 - a function, in which case that function is called once for each
664 character of OBJECT's printed representation;
665 - a symbol, in which case that symbol's function definition is called; or
666 - t, in which case the output is displayed in the echo area.
668 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
670 (Lisp_Object object
, Lisp_Object printcharfun
)
674 if (NILP (printcharfun
))
675 printcharfun
= Vstandard_output
;
677 print (object
, printcharfun
, 0);
682 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
683 doc
: /* Output the printed representation of OBJECT, with newlines around it.
684 Quoting characters are printed when needed to make output that `read'
685 can handle, whenever this is possible. For complex objects, the behavior
686 is controlled by `print-level' and `print-length', which see.
688 OBJECT is any of the Lisp data types: a number, a string, a symbol,
689 a list, a buffer, a window, a frame, etc.
691 A printed representation of an object is text which describes that object.
693 Optional argument PRINTCHARFUN is the output stream, which can be one
696 - a buffer, in which case output is inserted into that buffer at point;
697 - a marker, in which case output is inserted at marker's position;
698 - a function, in which case that function is called once for each
699 character of OBJECT's printed representation;
700 - a symbol, in which case that symbol's function definition is called; or
701 - t, in which case the output is displayed in the echo area.
703 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
705 (Lisp_Object object
, Lisp_Object printcharfun
)
710 if (NILP (printcharfun
))
711 printcharfun
= Vstandard_output
;
715 print (object
, printcharfun
, 1);
722 /* The subroutine object for external-debugging-output is kept here
723 for the convenience of the debugger. */
724 Lisp_Object Qexternal_debugging_output
;
726 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
727 doc
: /* Write CHARACTER to stderr.
728 You can call print while debugging emacs, and pass it this function
729 to make it write to the debugging output. */)
730 (Lisp_Object character
)
734 CHECK_NUMBER (character
);
735 ch
= XINT (character
);
736 if (ASCII_CHAR_P (ch
))
740 /* Send the output to a debugger (nothing happens if there isn't
742 if (print_output_debug_flag
)
744 char buf
[2] = {(char) XINT (character
), '\0'};
745 OutputDebugString (buf
);
751 unsigned char mbstr
[MAX_MULTIBYTE_LENGTH
];
752 ptrdiff_t len
= CHAR_STRING (ch
, mbstr
);
753 Lisp_Object encoded_ch
=
754 ENCODE_SYSTEM (make_multibyte_string ((char *) mbstr
, 1, len
));
756 fwrite (SSDATA (encoded_ch
), SBYTES (encoded_ch
), 1, stderr
);
758 if (print_output_debug_flag
)
759 OutputDebugString (SSDATA (encoded_ch
));
766 /* This function is never called. Its purpose is to prevent
767 print_output_debug_flag from being optimized away. */
769 extern void debug_output_compilation_hack (bool) EXTERNALLY_VISIBLE
;
771 debug_output_compilation_hack (bool x
)
773 print_output_debug_flag
= x
;
776 #if defined (GNU_LINUX)
778 /* This functionality is not vitally important in general, so we rely on
779 non-portable ability to use stderr as lvalue. */
781 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
783 static FILE *initial_stderr_stream
= NULL
;
785 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
787 "FDebug output file: \nP",
788 doc
: /* Redirect debugging output (stderr stream) to file FILE.
789 If FILE is nil, reset target to the initial stderr stream.
790 Optional arg APPEND non-nil (interactively, with prefix arg) means
791 append to existing target file. */)
792 (Lisp_Object file
, Lisp_Object append
)
794 if (initial_stderr_stream
!= NULL
)
800 stderr
= initial_stderr_stream
;
801 initial_stderr_stream
= NULL
;
805 file
= Fexpand_file_name (file
, Qnil
);
806 initial_stderr_stream
= stderr
;
807 stderr
= emacs_fopen (SSDATA (file
), NILP (append
) ? "w" : "a");
810 stderr
= initial_stderr_stream
;
811 initial_stderr_stream
= NULL
;
812 report_file_error ("Cannot open debugging output stream", file
);
817 #endif /* GNU_LINUX */
820 /* This is the interface for debugging printing. */
823 debug_print (Lisp_Object arg
)
825 Fprin1 (arg
, Qexternal_debugging_output
);
826 fprintf (stderr
, "\r\n");
829 void safe_debug_print (Lisp_Object
) EXTERNALLY_VISIBLE
;
831 safe_debug_print (Lisp_Object arg
)
833 int valid
= valid_lisp_object_p (arg
);
838 fprintf (stderr
, "#<%s_LISP_OBJECT 0x%08"pI
"x>\r\n",
839 !valid
? "INVALID" : "SOME",
844 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
846 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
847 See Info anchor `(elisp)Definition of signal' for some details on how this
848 error message is constructed. */)
851 struct buffer
*old
= current_buffer
;
855 /* If OBJ is (error STRING), just return STRING.
856 That is not only faster, it also avoids the need to allocate
857 space here when the error is due to memory full. */
858 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
859 && CONSP (XCDR (obj
))
860 && STRINGP (XCAR (XCDR (obj
)))
861 && NILP (XCDR (XCDR (obj
))))
862 return XCAR (XCDR (obj
));
864 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
866 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
867 value
= Fbuffer_string ();
871 set_buffer_internal (old
);
877 /* Print an error message for the error DATA onto Lisp output stream
878 STREAM (suitable for the print functions).
879 CONTEXT is a C string describing the context of the error.
880 CALLER is the Lisp function inside which the error was signaled. */
883 print_error_message (Lisp_Object data
, Lisp_Object stream
, const char *context
,
886 Lisp_Object errname
, errmsg
, file_error
, tail
;
890 write_string_1 (context
, -1, stream
);
892 /* If we know from where the error was signaled, show it in
894 if (!NILP (caller
) && SYMBOLP (caller
))
896 Lisp_Object cname
= SYMBOL_NAME (caller
);
897 ptrdiff_t cnamelen
= SBYTES (cname
);
899 char *name
= SAFE_ALLOCA (cnamelen
);
900 memcpy (name
, SDATA (cname
), cnamelen
);
901 message_dolog (name
, cnamelen
, 0, 0);
902 message_dolog (": ", 2, 0, 0);
906 errname
= Fcar (data
);
908 if (EQ (errname
, Qerror
))
913 errmsg
= Fcar (data
);
918 Lisp_Object error_conditions
= Fget (errname
, Qerror_conditions
);
919 errmsg
= Fget (errname
, Qerror_message
);
920 file_error
= Fmemq (Qfile_error
, error_conditions
);
923 /* Print an error message including the data items. */
925 tail
= Fcdr_safe (data
);
928 /* For file-error, make error message by concatenating
929 all the data items. They are all strings. */
930 if (!NILP (file_error
) && CONSP (tail
))
931 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
934 const char *sep
= ": ";
936 if (!STRINGP (errmsg
))
937 write_string_1 ("peculiar error", -1, stream
);
938 else if (SCHARS (errmsg
))
939 Fprinc (errmsg
, stream
);
943 for (; CONSP (tail
); tail
= XCDR (tail
), sep
= ", ")
948 write_string_1 (sep
, 2, stream
);
950 if (!NILP (file_error
)
951 || EQ (errname
, Qend_of_file
) || EQ (errname
, Quser_error
))
952 Fprinc (obj
, stream
);
954 Fprin1 (obj
, stream
);
964 * The buffer should be at least as large as the max string size of the
965 * largest float, printed in the biggest notation. This is undoubtedly
966 * 20d float_output_format, with the negative of the C-constant "HUGE"
969 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
971 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
972 * case of -1e307 in 20d float_output_format. What is one to do (short of
973 * re-writing _doprnt to be more sane)?
975 * Given the above, the buffer must be least FLOAT_TO_STRING_BUFSIZE bytes.
979 float_to_string (char *buf
, double data
)
985 /* Check for plus infinity in a way that won't lose
986 if there is no plus infinity. */
987 if (data
== data
/ 2 && data
> 1.0)
989 static char const infinity_string
[] = "1.0e+INF";
990 strcpy (buf
, infinity_string
);
991 return sizeof infinity_string
- 1;
993 /* Likewise for minus infinity. */
994 if (data
== data
/ 2 && data
< -1.0)
996 static char const minus_infinity_string
[] = "-1.0e+INF";
997 strcpy (buf
, minus_infinity_string
);
998 return sizeof minus_infinity_string
- 1;
1000 /* Check for NaN in a way that won't fail if there are no NaNs. */
1001 if (! (data
* 0.0 >= 0.0))
1003 /* Prepend "-" if the NaN's sign bit is negative.
1004 The sign bit of a double is the bit that is 1 in -0.0. */
1005 static char const NaN_string
[] = "0.0e+NaN";
1007 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
1010 u_minus_zero
.d
= - 0.0;
1011 for (i
= 0; i
< sizeof (double); i
++)
1012 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
1019 strcpy (buf
+ negative
, NaN_string
);
1020 return negative
+ sizeof NaN_string
- 1;
1023 if (NILP (Vfloat_output_format
)
1024 || !STRINGP (Vfloat_output_format
))
1027 /* Generate the fewest number of digits that represent the
1028 floating point value without losing information. */
1029 len
= dtoastr (buf
, FLOAT_TO_STRING_BUFSIZE
- 2, 0, 0, data
);
1030 /* The decimal point must be printed, or the byte compiler can
1031 get confused (Bug#8033). */
1034 else /* oink oink */
1036 /* Check that the spec we have is fully valid.
1037 This means not only valid for printf,
1038 but meant for floats, and reasonable. */
1039 cp
= SSDATA (Vfloat_output_format
);
1048 /* Check the width specification. */
1050 if ('0' <= *cp
&& *cp
<= '9')
1055 width
= (width
* 10) + (*cp
++ - '0');
1056 if (DBL_DIG
< width
)
1059 while (*cp
>= '0' && *cp
<= '9');
1061 /* A precision of zero is valid only for %f. */
1062 if (width
== 0 && *cp
!= 'f')
1066 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1072 len
= sprintf (buf
, SSDATA (Vfloat_output_format
), data
);
1075 /* Make sure there is a decimal point with digit after, or an
1076 exponent, so that the value is readable as a float. But don't do
1077 this with "%.0f"; it's valid for that not to produce a decimal
1078 point. Note that width can be 0 only for %.0f. */
1081 for (cp
= buf
; *cp
; cp
++)
1082 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1085 if (*cp
== '.' && cp
[1] == 0)
1105 print (Lisp_Object obj
, Lisp_Object printcharfun
, bool escapeflag
)
1107 new_backquote_output
= 0;
1109 /* Reset print_number_index and Vprint_number_table only when
1110 the variable Vprint_continuous_numbering is nil. Otherwise,
1111 the values of these variables will be kept between several
1113 if (NILP (Vprint_continuous_numbering
)
1114 || NILP (Vprint_number_table
))
1116 print_number_index
= 0;
1117 Vprint_number_table
= Qnil
;
1120 /* Construct Vprint_number_table for print-gensym and print-circle. */
1121 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1123 /* Construct Vprint_number_table.
1124 This increments print_number_index for the objects added. */
1126 print_preprocess (obj
);
1128 if (HASH_TABLE_P (Vprint_number_table
))
1129 { /* Remove unnecessary objects, which appear only once in OBJ;
1130 that is, whose status is Qt. */
1131 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vprint_number_table
);
1134 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
1135 if (!NILP (HASH_HASH (h
, i
))
1136 && EQ (HASH_VALUE (h
, i
), Qt
))
1137 Fremhash (HASH_KEY (h
, i
), Vprint_number_table
);
1142 print_object (obj
, printcharfun
, escapeflag
);
1145 #define PRINT_CIRCLE_CANDIDATE_P(obj) \
1146 (STRINGP (obj) || CONSP (obj) \
1147 || (VECTORLIKEP (obj) \
1148 && (VECTORP (obj) || COMPILEDP (obj) \
1149 || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \
1150 || HASH_TABLE_P (obj) || FONTP (obj))) \
1151 || (! NILP (Vprint_gensym) \
1153 && !SYMBOL_INTERNED_P (obj)))
1155 /* Construct Vprint_number_table according to the structure of OBJ.
1156 OBJ itself and all its elements will be added to Vprint_number_table
1157 recursively if it is a list, vector, compiled function, char-table,
1158 string (its text properties will be traced), or a symbol that has
1159 no obarray (this is for the print-gensym feature).
1160 The status fields of Vprint_number_table mean whether each object appears
1161 more than once in OBJ: Qnil at the first time, and Qt after that. */
1163 print_preprocess (Lisp_Object obj
)
1168 Lisp_Object halftail
;
1170 /* Avoid infinite recursion for circular nested structure
1171 in the case where Vprint_circle is nil. */
1172 if (NILP (Vprint_circle
))
1174 /* Give up if we go so deep that print_object will get an error. */
1175 /* See similar code in print_object. */
1176 if (print_depth
>= PRINT_CIRCLE
)
1177 error ("Apparently circular structure being printed");
1179 for (i
= 0; i
< print_depth
; i
++)
1180 if (EQ (obj
, being_printed
[i
]))
1182 being_printed
[print_depth
] = obj
;
1189 if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1191 if (!HASH_TABLE_P (Vprint_number_table
))
1193 Lisp_Object args
[2];
1196 Vprint_number_table
= Fmake_hash_table (2, args
);
1199 /* In case print-circle is nil and print-gensym is t,
1200 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1201 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1203 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1205 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1206 always print the gensym with a number. This is a special for
1207 the lisp function byte-compile-output-docform. */
1208 || (!NILP (Vprint_continuous_numbering
)
1210 && !SYMBOL_INTERNED_P (obj
)))
1211 { /* OBJ appears more than once. Let's remember that. */
1212 if (!INTEGERP (num
))
1214 print_number_index
++;
1215 /* Negative number indicates it hasn't been printed yet. */
1216 Fputhash (obj
, make_number (- print_number_index
),
1217 Vprint_number_table
);
1223 /* OBJ is not yet recorded. Let's add to the table. */
1224 Fputhash (obj
, Qt
, Vprint_number_table
);
1227 switch (XTYPE (obj
))
1230 /* A string may have text properties, which can be circular. */
1231 traverse_intervals_noorder (string_intervals (obj
),
1232 print_preprocess_string
, Qnil
);
1236 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1237 just as in print_object. */
1238 if (loop_count
&& EQ (obj
, halftail
))
1240 print_preprocess (XCAR (obj
));
1243 if (!(loop_count
& 1))
1244 halftail
= XCDR (halftail
);
1247 case Lisp_Vectorlike
:
1249 if (size
& PSEUDOVECTOR_FLAG
)
1250 size
&= PSEUDOVECTOR_SIZE_MASK
;
1251 for (i
= (SUB_CHAR_TABLE_P (obj
)
1252 ? SUB_CHAR_TABLE_OFFSET
: 0); i
< size
; i
++)
1253 print_preprocess (AREF (obj
, i
));
1254 if (HASH_TABLE_P (obj
))
1255 { /* For hash tables, the key_and_value slot is past
1256 `size' because it needs to be marked specially in case
1257 the table is weak. */
1258 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1259 print_preprocess (h
->key_and_value
);
1271 print_preprocess_string (INTERVAL interval
, Lisp_Object arg
)
1273 print_preprocess (interval
->plist
);
1276 static void print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
);
1278 #define PRINT_STRING_NON_CHARSET_FOUND 1
1279 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1281 /* Bitwise or of the above macros. */
1282 static int print_check_string_result
;
1285 print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
)
1289 if (NILP (interval
->plist
)
1290 || (print_check_string_result
== (PRINT_STRING_NON_CHARSET_FOUND
1291 | PRINT_STRING_UNSAFE_CHARSET_FOUND
)))
1293 for (val
= interval
->plist
; CONSP (val
) && ! EQ (XCAR (val
), Qcharset
);
1294 val
= XCDR (XCDR (val
)));
1297 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1300 if (! (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
))
1302 if (! EQ (val
, interval
->plist
)
1303 || CONSP (XCDR (XCDR (val
))))
1304 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1306 if (NILP (Vprint_charset_text_property
)
1307 || ! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1310 ptrdiff_t charpos
= interval
->position
;
1311 ptrdiff_t bytepos
= string_char_to_byte (string
, charpos
);
1312 Lisp_Object charset
;
1314 charset
= XCAR (XCDR (val
));
1315 for (i
= 0; i
< LENGTH (interval
); i
++)
1317 FETCH_STRING_CHAR_ADVANCE (c
, string
, charpos
, bytepos
);
1318 if (! ASCII_CHAR_P (c
)
1319 && ! EQ (CHARSET_NAME (CHAR_CHARSET (c
)), charset
))
1321 print_check_string_result
|= PRINT_STRING_UNSAFE_CHARSET_FOUND
;
1328 /* The value is (charset . nil). */
1329 static Lisp_Object print_prune_charset_plist
;
1332 print_prune_string_charset (Lisp_Object string
)
1334 print_check_string_result
= 0;
1335 traverse_intervals (string_intervals (string
), 0,
1336 print_check_string_charset_prop
, string
);
1337 if (! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1339 string
= Fcopy_sequence (string
);
1340 if (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
)
1342 if (NILP (print_prune_charset_plist
))
1343 print_prune_charset_plist
= list1 (Qcharset
);
1344 Fremove_text_properties (make_number (0),
1345 make_number (SCHARS (string
)),
1346 print_prune_charset_plist
, string
);
1349 Fset_text_properties (make_number (0), make_number (SCHARS (string
)),
1356 print_object (Lisp_Object obj
, Lisp_Object printcharfun
, bool escapeflag
)
1358 char buf
[max (sizeof "from..to..in " + 2 * INT_STRLEN_BOUND (EMACS_INT
),
1359 max (sizeof " . #" + INT_STRLEN_BOUND (printmax_t
),
1364 /* Detect circularities and truncate them. */
1365 if (NILP (Vprint_circle
))
1367 /* Simple but incomplete way. */
1370 /* See similar code in print_preprocess. */
1371 if (print_depth
>= PRINT_CIRCLE
)
1372 error ("Apparently circular structure being printed");
1374 for (i
= 0; i
< print_depth
; i
++)
1375 if (EQ (obj
, being_printed
[i
]))
1377 int len
= sprintf (buf
, "#%d", i
);
1378 strout (buf
, len
, len
, printcharfun
);
1381 being_printed
[print_depth
] = obj
;
1383 else if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1385 /* With the print-circle feature. */
1386 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1389 EMACS_INT n
= XINT (num
);
1391 { /* Add a prefix #n= if OBJ has not yet been printed;
1392 that is, its status field is nil. */
1393 int len
= sprintf (buf
, "#%"pI
"d=", -n
);
1394 strout (buf
, len
, len
, printcharfun
);
1395 /* OBJ is going to be printed. Remember that fact. */
1396 Fputhash (obj
, make_number (- n
), Vprint_number_table
);
1400 /* Just print #n# if OBJ has already been printed. */
1401 int len
= sprintf (buf
, "#%"pI
"d#", n
);
1402 strout (buf
, len
, len
, printcharfun
);
1410 switch (XTYPE (obj
))
1414 int len
= sprintf (buf
, "%"pI
"d", XINT (obj
));
1415 strout (buf
, len
, len
, printcharfun
);
1421 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
1422 int len
= float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1423 strout (pigbuf
, len
, len
, printcharfun
);
1429 print_string (obj
, printcharfun
);
1432 register ptrdiff_t i
, i_byte
;
1433 struct gcpro gcpro1
;
1434 ptrdiff_t size_byte
;
1435 /* 1 means we must ensure that the next character we output
1436 cannot be taken as part of a hex character escape. */
1437 bool need_nonhex
= 0;
1438 bool multibyte
= STRING_MULTIBYTE (obj
);
1442 if (! EQ (Vprint_charset_text_property
, Qt
))
1443 obj
= print_prune_string_charset (obj
);
1445 if (string_intervals (obj
))
1452 size_byte
= SBYTES (obj
);
1454 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1456 /* Here, we must convert each multi-byte form to the
1457 corresponding character code before handing it to PRINTCHAR. */
1460 FETCH_STRING_CHAR_ADVANCE (c
, obj
, i
, i_byte
);
1464 if (c
== '\n' && print_escape_newlines
)
1469 else if (c
== '\f' && print_escape_newlines
)
1475 && (CHAR_BYTE8_P (c
)
1476 || (! ASCII_CHAR_P (c
) && print_escape_multibyte
)))
1478 /* When multibyte is disabled,
1479 print multibyte string chars using hex escapes.
1480 For a char code that could be in a unibyte string,
1481 when found in a multibyte string, always use a hex escape
1482 so it reads back as multibyte. */
1486 if (CHAR_BYTE8_P (c
))
1487 len
= sprintf (outbuf
, "\\%03o", CHAR_TO_BYTE8 (c
));
1490 len
= sprintf (outbuf
, "\\x%04x", c
);
1493 strout (outbuf
, len
, len
, printcharfun
);
1495 else if (! multibyte
1496 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_CHAR_P (c
)
1497 && print_escape_nonascii
)
1499 /* When printing in a multibyte buffer
1500 or when explicitly requested,
1501 print single-byte non-ASCII string chars
1502 using octal escapes. */
1504 int len
= sprintf (outbuf
, "\\%03o", c
);
1505 strout (outbuf
, len
, len
, printcharfun
);
1509 /* If we just had a hex escape, and this character
1510 could be taken as part of it,
1511 output `\ ' to prevent that. */
1515 if ((c
>= 'a' && c
<= 'f')
1516 || (c
>= 'A' && c
<= 'F')
1517 || (c
>= '0' && c
<= '9'))
1518 strout ("\\ ", -1, -1, printcharfun
);
1521 if (c
== '\"' || c
== '\\')
1528 if (string_intervals (obj
))
1530 traverse_intervals (string_intervals (obj
),
1531 0, print_interval
, printcharfun
);
1542 unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1543 unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1545 ptrdiff_t i
, i_byte
;
1546 ptrdiff_t size_byte
;
1549 name
= SYMBOL_NAME (obj
);
1551 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1554 /* If symbol name begins with a digit, and ends with a digit,
1555 and contains nothing but digits and `e', it could be treated
1556 as a number. So set CONFUSING.
1558 Symbols that contain periods could also be taken as numbers,
1559 but periods are always escaped, so we don't have to worry
1561 else if (*p
>= '0' && *p
<= '9'
1562 && end
[-1] >= '0' && end
[-1] <= '9')
1564 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1565 /* Needed for \2e10. */
1566 || *p
== 'e' || *p
== 'E'))
1568 confusing
= (end
== p
);
1573 size_byte
= SBYTES (name
);
1575 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1580 else if (size_byte
== 0)
1587 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1589 /* Here, we must convert each multi-byte form to the
1590 corresponding character code before handing it to PRINTCHAR. */
1591 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1596 if (c
== '\"' || c
== '\\' || c
== '\''
1597 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1598 || c
== ',' || c
== '.' || c
== '`'
1599 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1601 PRINTCHAR ('\\'), confusing
= 0;
1609 /* If deeper than spec'd depth, print placeholder. */
1610 if (INTEGERP (Vprint_level
)
1611 && print_depth
> XINT (Vprint_level
))
1612 strout ("...", -1, -1, printcharfun
);
1613 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1614 && (EQ (XCAR (obj
), Qquote
)))
1617 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1619 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1620 && (EQ (XCAR (obj
), Qfunction
)))
1624 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1626 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1627 && ((EQ (XCAR (obj
), Qbackquote
))))
1629 print_object (XCAR (obj
), printcharfun
, 0);
1630 new_backquote_output
++;
1631 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1632 new_backquote_output
--;
1634 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1635 && new_backquote_output
1636 && ((EQ (XCAR (obj
), Qbackquote
)
1637 || EQ (XCAR (obj
), Qcomma
)
1638 || EQ (XCAR (obj
), Qcomma_at
)
1639 || EQ (XCAR (obj
), Qcomma_dot
))))
1641 print_object (XCAR (obj
), printcharfun
, 0);
1642 new_backquote_output
--;
1643 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1644 new_backquote_output
++;
1651 printmax_t i
, print_length
;
1652 Lisp_Object halftail
= obj
;
1654 /* Negative values of print-length are invalid in CL.
1655 Treat them like nil, as CMUCL does. */
1656 if (NATNUMP (Vprint_length
))
1657 print_length
= XFASTINT (Vprint_length
);
1659 print_length
= TYPE_MAXIMUM (printmax_t
);
1664 /* Detect circular list. */
1665 if (NILP (Vprint_circle
))
1667 /* Simple but incomplete way. */
1668 if (i
!= 0 && EQ (obj
, halftail
))
1670 int len
= sprintf (buf
, " . #%"pMd
, i
/ 2);
1671 strout (buf
, len
, len
, printcharfun
);
1677 /* With the print-circle feature. */
1680 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1683 strout (" . ", 3, 3, printcharfun
);
1684 print_object (obj
, printcharfun
, escapeflag
);
1693 if (print_length
<= i
)
1695 strout ("...", 3, 3, printcharfun
);
1700 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1704 halftail
= XCDR (halftail
);
1708 /* OBJ non-nil here means it's the end of a dotted list. */
1711 strout (" . ", 3, 3, printcharfun
);
1712 print_object (obj
, printcharfun
, escapeflag
);
1720 case Lisp_Vectorlike
:
1725 strout ("#<process ", -1, -1, printcharfun
);
1726 print_string (XPROCESS (obj
)->name
, printcharfun
);
1730 print_string (XPROCESS (obj
)->name
, printcharfun
);
1732 else if (BOOL_VECTOR_P (obj
))
1737 struct gcpro gcpro1
;
1738 EMACS_INT size
= bool_vector_size (obj
);
1739 ptrdiff_t size_in_chars
= bool_vector_bytes (size
);
1740 ptrdiff_t real_size_in_chars
= size_in_chars
;
1745 len
= sprintf (buf
, "%"pI
"d", size
);
1746 strout (buf
, len
, len
, printcharfun
);
1749 /* Don't print more characters than the specified maximum.
1750 Negative values of print-length are invalid. Treat them
1751 like a print-length of nil. */
1752 if (NATNUMP (Vprint_length
)
1753 && XFASTINT (Vprint_length
) < size_in_chars
)
1754 size_in_chars
= XFASTINT (Vprint_length
);
1756 for (i
= 0; i
< size_in_chars
; i
++)
1759 c
= bool_vector_uchar_data (obj
)[i
];
1760 if (c
== '\n' && print_escape_newlines
)
1765 else if (c
== '\f' && print_escape_newlines
)
1770 else if (c
> '\177')
1772 /* Use octal escapes to avoid encoding issues. */
1774 PRINTCHAR ('0' + ((c
>> 6) & 3));
1775 PRINTCHAR ('0' + ((c
>> 3) & 7));
1776 PRINTCHAR ('0' + (c
& 7));
1780 if (c
== '\"' || c
== '\\')
1786 if (size_in_chars
< real_size_in_chars
)
1787 strout (" ...", 4, 4, printcharfun
);
1792 else if (SUBRP (obj
))
1794 strout ("#<subr ", -1, -1, printcharfun
);
1795 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
);
1798 #ifdef HAVE_XWIDGETS
1799 else if (XWIDGETP (obj
))
1801 strout ("#<xwidget ", -1, -1, printcharfun
);
1804 else if (XWIDGET_VIEW_P (obj
))
1806 strout ("#<xwidget-view ", -1, -1, printcharfun
);
1810 else if (WINDOWP (obj
))
1813 strout ("#<window ", -1, -1, printcharfun
);
1814 len
= sprintf (buf
, "%d", XWINDOW (obj
)->sequence_number
);
1815 strout (buf
, len
, len
, printcharfun
);
1816 if (BUFFERP (XWINDOW (obj
)->contents
))
1818 strout (" on ", -1, -1, printcharfun
);
1819 print_string (BVAR (XBUFFER (XWINDOW (obj
)->contents
), name
),
1824 else if (TERMINALP (obj
))
1827 struct terminal
*t
= XTERMINAL (obj
);
1828 strout ("#<terminal ", -1, -1, printcharfun
);
1829 len
= sprintf (buf
, "%d", t
->id
);
1830 strout (buf
, len
, len
, printcharfun
);
1833 strout (" on ", -1, -1, printcharfun
);
1834 strout (t
->name
, -1, -1, printcharfun
);
1838 else if (HASH_TABLE_P (obj
))
1840 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1842 ptrdiff_t real_size
, size
;
1846 strout ("#<hash-table", -1, -1, printcharfun
);
1847 if (SYMBOLP (h
->test
))
1851 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
);
1853 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
);
1855 len
= sprintf (buf
, "%"pD
"d/%"pD
"d", h
->count
, ASIZE (h
->next
));
1856 strout (buf
, len
, len
, printcharfun
);
1858 len
= sprintf (buf
, " %p>", ptr
);
1859 strout (buf
, len
, len
, printcharfun
);
1861 /* Implement a readable output, e.g.:
1862 #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
1863 /* Always print the size. */
1864 len
= sprintf (buf
, "#s(hash-table size %"pD
"d", ASIZE (h
->next
));
1865 strout (buf
, len
, len
, printcharfun
);
1867 if (!NILP (h
->test
.name
))
1869 strout (" test ", -1, -1, printcharfun
);
1870 print_object (h
->test
.name
, printcharfun
, escapeflag
);
1873 if (!NILP (h
->weak
))
1875 strout (" weakness ", -1, -1, printcharfun
);
1876 print_object (h
->weak
, printcharfun
, escapeflag
);
1879 if (!NILP (h
->rehash_size
))
1881 strout (" rehash-size ", -1, -1, printcharfun
);
1882 print_object (h
->rehash_size
, printcharfun
, escapeflag
);
1885 if (!NILP (h
->rehash_threshold
))
1887 strout (" rehash-threshold ", -1, -1, printcharfun
);
1888 print_object (h
->rehash_threshold
, printcharfun
, escapeflag
);
1891 strout (" data ", -1, -1, printcharfun
);
1893 /* Print the data here as a plist. */
1894 real_size
= HASH_TABLE_SIZE (h
);
1897 /* Don't print more elements than the specified maximum. */
1898 if (NATNUMP (Vprint_length
)
1899 && XFASTINT (Vprint_length
) < size
)
1900 size
= XFASTINT (Vprint_length
);
1903 for (i
= 0; i
< size
; i
++)
1904 if (!NILP (HASH_HASH (h
, i
)))
1906 if (i
) PRINTCHAR (' ');
1907 print_object (HASH_KEY (h
, i
), printcharfun
, escapeflag
);
1909 print_object (HASH_VALUE (h
, i
), printcharfun
, escapeflag
);
1912 if (size
< real_size
)
1913 strout (" ...", 4, 4, printcharfun
);
1919 else if (BUFFERP (obj
))
1921 if (!BUFFER_LIVE_P (XBUFFER (obj
)))
1922 strout ("#<killed buffer>", -1, -1, printcharfun
);
1923 else if (escapeflag
)
1925 strout ("#<buffer ", -1, -1, printcharfun
);
1926 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1930 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1932 else if (WINDOW_CONFIGURATIONP (obj
))
1934 strout ("#<window-configuration>", -1, -1, printcharfun
);
1936 else if (FRAMEP (obj
))
1939 void *ptr
= XFRAME (obj
);
1940 Lisp_Object frame_name
= XFRAME (obj
)->name
;
1942 strout ((FRAME_LIVE_P (XFRAME (obj
))
1943 ? "#<frame " : "#<dead frame "),
1944 -1, -1, printcharfun
);
1945 if (!STRINGP (frame_name
))
1947 /* A frame could be too young and have no name yet;
1949 if (SYMBOLP (frame_name
))
1950 frame_name
= Fsymbol_name (frame_name
);
1951 else /* can't happen: name should be either nil or string */
1952 frame_name
= build_string ("*INVALID*FRAME*NAME*");
1954 print_string (frame_name
, printcharfun
);
1955 len
= sprintf (buf
, " %p>", ptr
);
1956 strout (buf
, len
, len
, printcharfun
);
1958 else if (FONTP (obj
))
1962 if (! FONT_OBJECT_P (obj
))
1964 if (FONT_SPEC_P (obj
))
1965 strout ("#<font-spec", -1, -1, printcharfun
);
1967 strout ("#<font-entity", -1, -1, printcharfun
);
1968 for (i
= 0; i
< FONT_SPEC_MAX
; i
++)
1971 if (i
< FONT_WEIGHT_INDEX
|| i
> FONT_WIDTH_INDEX
)
1972 print_object (AREF (obj
, i
), printcharfun
, escapeflag
);
1974 print_object (font_style_symbolic (obj
, i
, 0),
1975 printcharfun
, escapeflag
);
1980 strout ("#<font-object ", -1, -1, printcharfun
);
1981 print_object (AREF (obj
, FONT_NAME_INDEX
), printcharfun
,
1988 ptrdiff_t size
= ASIZE (obj
);
1989 if (COMPILEDP (obj
))
1992 size
&= PSEUDOVECTOR_SIZE_MASK
;
1994 if (CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
))
1996 /* We print a char-table as if it were a vector,
1997 lumping the parent and default slots in with the
1998 character slots. But we add #^ as a prefix. */
2000 /* Make each lowest sub_char_table start a new line.
2001 Otherwise we'll make a line extremely long, which
2002 results in slow redisplay. */
2003 if (SUB_CHAR_TABLE_P (obj
)
2004 && XSUB_CHAR_TABLE (obj
)->depth
== 3)
2008 if (SUB_CHAR_TABLE_P (obj
))
2010 size
&= PSEUDOVECTOR_SIZE_MASK
;
2012 if (size
& PSEUDOVECTOR_FLAG
)
2017 int i
, idx
= SUB_CHAR_TABLE_P (obj
) ? SUB_CHAR_TABLE_OFFSET
: 0;
2018 register Lisp_Object tem
;
2019 ptrdiff_t real_size
= size
;
2021 /* For a sub char-table, print heading non-Lisp data first. */
2022 if (SUB_CHAR_TABLE_P (obj
))
2024 i
= sprintf (buf
, "%d %d", XSUB_CHAR_TABLE (obj
)->depth
,
2025 XSUB_CHAR_TABLE (obj
)->min_char
);
2026 strout (buf
, i
, i
, printcharfun
);
2029 /* Don't print more elements than the specified maximum. */
2030 if (NATNUMP (Vprint_length
)
2031 && XFASTINT (Vprint_length
) < size
)
2032 size
= XFASTINT (Vprint_length
);
2034 for (i
= idx
; i
< size
; i
++)
2036 if (i
) PRINTCHAR (' ');
2037 tem
= AREF (obj
, i
);
2038 print_object (tem
, printcharfun
, escapeflag
);
2040 if (size
< real_size
)
2041 strout (" ...", 4, 4, printcharfun
);
2048 switch (XMISCTYPE (obj
))
2050 case Lisp_Misc_Marker
:
2051 strout ("#<marker ", -1, -1, printcharfun
);
2052 /* Do you think this is necessary? */
2053 if (XMARKER (obj
)->insertion_type
!= 0)
2054 strout ("(moves after insertion) ", -1, -1, printcharfun
);
2055 if (! XMARKER (obj
)->buffer
)
2056 strout ("in no buffer", -1, -1, printcharfun
);
2059 int len
= sprintf (buf
, "at %"pD
"d", marker_position (obj
));
2060 strout (buf
, len
, len
, printcharfun
);
2061 strout (" in ", -1, -1, printcharfun
);
2062 print_string (BVAR (XMARKER (obj
)->buffer
, name
), printcharfun
);
2067 case Lisp_Misc_Overlay
:
2068 strout ("#<overlay ", -1, -1, printcharfun
);
2069 if (! XMARKER (OVERLAY_START (obj
))->buffer
)
2070 strout ("in no buffer", -1, -1, printcharfun
);
2073 int len
= sprintf (buf
, "from %"pD
"d to %"pD
"d in ",
2074 marker_position (OVERLAY_START (obj
)),
2075 marker_position (OVERLAY_END (obj
)));
2076 strout (buf
, len
, len
, printcharfun
);
2077 print_string (BVAR (XMARKER (OVERLAY_START (obj
))->buffer
, name
),
2083 /* Remaining cases shouldn't happen in normal usage, but let's
2084 print them anyway for the benefit of the debugger. */
2086 case Lisp_Misc_Free
:
2087 strout ("#<misc free cell>", -1, -1, printcharfun
);
2090 case Lisp_Misc_Save_Value
:
2093 struct Lisp_Save_Value
*v
= XSAVE_VALUE (obj
);
2095 strout ("#<save-value ", -1, -1, printcharfun
);
2097 if (v
->save_type
== SAVE_TYPE_MEMORY
)
2099 ptrdiff_t amount
= v
->data
[1].integer
;
2103 /* valid_lisp_object_p is reliable, so try to print up
2104 to 8 saved objects. This code is rarely used, so
2105 it's OK that valid_lisp_object_p is slow. */
2107 int limit
= min (amount
, 8);
2108 Lisp_Object
*area
= v
->data
[0].pointer
;
2110 i
= sprintf (buf
, "with %"pD
"d objects", amount
);
2111 strout (buf
, i
, i
, printcharfun
);
2113 for (i
= 0; i
< limit
; i
++)
2115 Lisp_Object maybe
= area
[i
];
2116 int valid
= valid_lisp_object_p (maybe
);
2121 print_object (maybe
, printcharfun
, escapeflag
);
2124 strout (valid
? " <some>" : " <invalid>",
2125 -1, -1, printcharfun
);
2127 if (i
== limit
&& i
< amount
)
2128 strout (" ...", 4, 4, printcharfun
);
2130 #else /* not GC_MARK_STACK */
2132 /* There is no reliable way to determine whether the objects
2133 are initialized, so do not try to print them. */
2135 i
= sprintf (buf
, "with %"pD
"d objects", amount
);
2136 strout (buf
, i
, i
, printcharfun
);
2138 #endif /* GC_MARK_STACK */
2142 /* Print each slot according to its type. */
2144 for (index
= 0; index
< SAVE_VALUE_SLOTS
; index
++)
2149 switch (save_type (v
, index
))
2152 i
= sprintf (buf
, "<unused>");
2156 i
= sprintf (buf
, "<pointer %p>",
2157 v
->data
[index
].pointer
);
2160 case SAVE_FUNCPOINTER
:
2161 i
= sprintf (buf
, "<funcpointer %p>",
2162 ((void *) (intptr_t)
2163 v
->data
[index
].funcpointer
));
2167 i
= sprintf (buf
, "<integer %"pD
"d>",
2168 v
->data
[index
].integer
);
2172 print_object (v
->data
[index
].object
, printcharfun
,
2180 strout (buf
, i
, i
, printcharfun
);
2196 /* We're in trouble if this happens!
2197 Probably should just emacs_abort (). */
2198 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
);
2200 len
= sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2201 else if (VECTORLIKEP (obj
))
2202 len
= sprintf (buf
, "(PVEC 0x%08"pD
"x)", ASIZE (obj
));
2204 len
= sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2205 strout (buf
, len
, len
, printcharfun
);
2206 strout (" Save your buffers immediately and please report this bug>",
2207 -1, -1, printcharfun
);
2215 /* Print a description of INTERVAL using PRINTCHARFUN.
2216 This is part of printing a string that has text properties. */
2219 print_interval (INTERVAL interval
, Lisp_Object printcharfun
)
2221 if (NILP (interval
->plist
))
2224 print_object (make_number (interval
->position
), printcharfun
, 1);
2226 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2229 print_object (interval
->plist
, printcharfun
, 1);
2232 /* Initialize debug_print stuff early to have it working from the very
2236 init_print_once (void)
2238 DEFSYM (Qexternal_debugging_output
, "external-debugging-output");
2239 defsubr (&Sexternal_debugging_output
);
2243 syms_of_print (void)
2245 DEFSYM (Qtemp_buffer_setup_hook
, "temp-buffer-setup-hook");
2247 DEFVAR_LISP ("standard-output", Vstandard_output
,
2248 doc
: /* Output stream `print' uses by default for outputting a character.
2249 This may be any function of one argument.
2250 It may also be a buffer (output is inserted before point)
2251 or a marker (output is inserted and the marker is advanced)
2252 or the symbol t (output appears in the echo area). */);
2253 Vstandard_output
= Qt
;
2254 DEFSYM (Qstandard_output
, "standard-output");
2256 DEFVAR_LISP ("float-output-format", Vfloat_output_format
,
2257 doc
: /* The format descriptor string used to print floats.
2258 This is a %-spec like those accepted by `printf' in C,
2259 but with some restrictions. It must start with the two characters `%.'.
2260 After that comes an integer precision specification,
2261 and then a letter which controls the format.
2262 The letters allowed are `e', `f' and `g'.
2263 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2264 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2265 Use `g' to choose the shorter of those two formats for the number at hand.
2266 The precision in any of these cases is the number of digits following
2267 the decimal point. With `f', a precision of 0 means to omit the
2268 decimal point. 0 is not allowed with `e' or `g'.
2270 A value of nil means to use the shortest notation
2271 that represents the number without losing information. */);
2272 Vfloat_output_format
= Qnil
;
2273 DEFSYM (Qfloat_output_format
, "float-output-format");
2275 DEFVAR_LISP ("print-length", Vprint_length
,
2276 doc
: /* Maximum length of list to print before abbreviating.
2277 A value of nil means no limit. See also `eval-expression-print-length'. */);
2278 Vprint_length
= Qnil
;
2280 DEFVAR_LISP ("print-level", Vprint_level
,
2281 doc
: /* Maximum depth of list nesting to print before abbreviating.
2282 A value of nil means no limit. See also `eval-expression-print-level'. */);
2283 Vprint_level
= Qnil
;
2285 DEFVAR_BOOL ("print-escape-newlines", print_escape_newlines
,
2286 doc
: /* Non-nil means print newlines in strings as `\\n'.
2287 Also print formfeeds as `\\f'. */);
2288 print_escape_newlines
= 0;
2290 DEFVAR_BOOL ("print-escape-nonascii", print_escape_nonascii
,
2291 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2292 \(OOO is the octal representation of the character code.)
2293 Only single-byte characters are affected, and only in `prin1'.
2294 When the output goes in a multibyte buffer, this feature is
2295 enabled regardless of the value of the variable. */);
2296 print_escape_nonascii
= 0;
2298 DEFVAR_BOOL ("print-escape-multibyte", print_escape_multibyte
,
2299 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2300 \(XXXX is the hex representation of the character code.)
2301 This affects only `prin1'. */);
2302 print_escape_multibyte
= 0;
2304 DEFVAR_BOOL ("print-quoted", print_quoted
,
2305 doc
: /* Non-nil means print quoted forms with reader syntax.
2306 I.e., (quote foo) prints as 'foo, (function foo) as #'foo. */);
2309 DEFVAR_LISP ("print-gensym", Vprint_gensym
,
2310 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2311 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2312 When the uninterned symbol appears within a recursive data structure,
2313 and the symbol appears more than once, in addition use the #N# and #N=
2314 constructs as needed, so that multiple references to the same symbol are
2315 shared once again when the text is read back. */);
2316 Vprint_gensym
= Qnil
;
2318 DEFVAR_LISP ("print-circle", Vprint_circle
,
2319 doc
: /* Non-nil means print recursive structures using #N= and #N# syntax.
2320 If nil, printing proceeds recursively and may lead to
2321 `max-lisp-eval-depth' being exceeded or an error may occur:
2322 \"Apparently circular structure being printed.\" Also see
2323 `print-length' and `print-level'.
2324 If non-nil, shared substructures anywhere in the structure are printed
2325 with `#N=' before the first occurrence (in the order of the print
2326 representation) and `#N#' in place of each subsequent occurrence,
2327 where N is a positive decimal integer. */);
2328 Vprint_circle
= Qnil
;
2330 DEFVAR_LISP ("print-continuous-numbering", Vprint_continuous_numbering
,
2331 doc
: /* Non-nil means number continuously across print calls.
2332 This affects the numbers printed for #N= labels and #M# references.
2333 See also `print-circle', `print-gensym', and `print-number-table'.
2334 This variable should not be set with `setq'; bind it with a `let' instead. */);
2335 Vprint_continuous_numbering
= Qnil
;
2337 DEFVAR_LISP ("print-number-table", Vprint_number_table
,
2338 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2339 The Lisp printer uses this vector to detect Lisp objects referenced more
2342 When you bind `print-continuous-numbering' to t, you should probably
2343 also bind `print-number-table' to nil. This ensures that the value of
2344 `print-number-table' can be garbage-collected once the printing is
2345 done. If all elements of `print-number-table' are nil, it means that
2346 the printing done so far has not found any shared structure or objects
2347 that need to be recorded in the table. */);
2348 Vprint_number_table
= Qnil
;
2350 DEFVAR_LISP ("print-charset-text-property", Vprint_charset_text_property
,
2351 doc
: /* A flag to control printing of `charset' text property on printing a string.
2352 The value must be nil, t, or `default'.
2354 If the value is nil, don't print the text property `charset'.
2356 If the value is t, always print the text property `charset'.
2358 If the value is `default', print the text property `charset' only when
2359 the value is different from what is guessed in the current charset
2361 Vprint_charset_text_property
= Qdefault
;
2363 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2364 staticpro (&Vprin1_to_string_buffer
);
2367 defsubr (&Sprin1_to_string
);
2368 defsubr (&Serror_message_string
);
2372 defsubr (&Swrite_char
);
2373 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2374 defsubr (&Sredirect_debugging_output
);
2377 DEFSYM (Qprint_escape_newlines
, "print-escape-newlines");
2378 DEFSYM (Qprint_escape_multibyte
, "print-escape-multibyte");
2379 DEFSYM (Qprint_escape_nonascii
, "print-escape-nonascii");
2381 print_prune_charset_plist
= Qnil
;
2382 staticpro (&print_prune_charset_plist
);