1 /* Lisp object printing and output streams.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2014 Free Software
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
26 #include "character.h"
33 #include "dispextern.h"
35 #include "intervals.h"
36 #include "blockinput.h"
37 #include "termhooks.h" /* For struct terminal. */
40 Lisp_Object Qstandard_output
;
42 static Lisp_Object Qtemp_buffer_setup_hook
;
44 /* These are used to print like we read. */
46 static Lisp_Object Qfloat_output_format
;
51 /* Avoid actual stack overflow in print. */
52 static ptrdiff_t print_depth
;
54 /* Level of nesting inside outputting backquote in new style. */
55 static ptrdiff_t new_backquote_output
;
57 /* Detect most circularities to print finite output. */
58 #define PRINT_CIRCLE 200
59 static Lisp_Object being_printed
[PRINT_CIRCLE
];
61 /* When printing into a buffer, first we put the text in this
62 block, then insert it all at once. */
63 static char *print_buffer
;
65 /* Size allocated in print_buffer. */
66 static ptrdiff_t print_buffer_size
;
67 /* Chars stored in print_buffer. */
68 static ptrdiff_t print_buffer_pos
;
69 /* Bytes stored in print_buffer. */
70 static ptrdiff_t print_buffer_pos_byte
;
72 Lisp_Object Qprint_escape_newlines
;
73 static Lisp_Object Qprint_escape_multibyte
, Qprint_escape_nonascii
;
75 /* Vprint_number_table is a table, that keeps objects that are going to
76 be printed, to allow use of #n= and #n# to express sharing.
77 For any given object, the table can give the following values:
78 t the object will be printed only once.
79 -N the object will be printed several times and will take number N.
80 N the object has been printed so we can refer to it as #N#.
81 print_number_index holds the largest N already used.
82 N has to be striclty larger than 0 since we need to distinguish -N. */
83 static ptrdiff_t print_number_index
;
84 static void print_interval (INTERVAL interval
, Lisp_Object printcharfun
);
86 /* GDB resets this to zero on W32 to disable OutputDebugString calls. */
87 bool print_output_debug_flag EXTERNALLY_VISIBLE
= 1;
90 /* Low level output routines for characters and strings. */
92 /* Lisp functions to do output using a stream
93 must have the stream in a variable called printcharfun
94 and must start with PRINTPREPARE, end with PRINTFINISH,
95 and use PRINTDECLARE to declare common variables.
96 Use PRINTCHAR to output one character,
97 or call strout to output a block of characters. */
99 #define PRINTDECLARE \
100 struct buffer *old = current_buffer; \
101 ptrdiff_t old_point = -1, start_point = -1; \
102 ptrdiff_t old_point_byte = -1, start_point_byte = -1; \
103 ptrdiff_t specpdl_count = SPECPDL_INDEX (); \
104 bool free_print_buffer = 0; \
106 = !NILP (BVAR (current_buffer, enable_multibyte_characters)); \
109 #define PRINTPREPARE \
110 original = printcharfun; \
111 if (NILP (printcharfun)) printcharfun = Qt; \
112 if (BUFFERP (printcharfun)) \
114 if (XBUFFER (printcharfun) != current_buffer) \
115 Fset_buffer (printcharfun); \
116 printcharfun = Qnil; \
118 if (MARKERP (printcharfun)) \
120 ptrdiff_t marker_pos; \
121 if (! XMARKER (printcharfun)->buffer) \
122 error ("Marker does not point anywhere"); \
123 if (XMARKER (printcharfun)->buffer != current_buffer) \
124 set_buffer_internal (XMARKER (printcharfun)->buffer); \
125 marker_pos = marker_position (printcharfun); \
126 if (marker_pos < BEGV || marker_pos > ZV) \
127 signal_error ("Marker is outside the accessible " \
128 "part of the buffer", printcharfun); \
130 old_point_byte = PT_BYTE; \
131 SET_PT_BOTH (marker_pos, \
132 marker_byte_position (printcharfun)); \
134 start_point_byte = PT_BYTE; \
135 printcharfun = Qnil; \
137 if (NILP (printcharfun)) \
139 Lisp_Object string; \
140 if (NILP (BVAR (current_buffer, enable_multibyte_characters)) \
141 && ! print_escape_multibyte) \
142 specbind (Qprint_escape_multibyte, Qt); \
143 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)) \
144 && ! print_escape_nonascii) \
145 specbind (Qprint_escape_nonascii, Qt); \
146 if (print_buffer != 0) \
148 string = make_string_from_bytes (print_buffer, \
150 print_buffer_pos_byte); \
151 record_unwind_protect (print_unwind, string); \
155 int new_size = 1000; \
156 print_buffer = xmalloc (new_size); \
157 print_buffer_size = new_size; \
158 free_print_buffer = 1; \
160 print_buffer_pos = 0; \
161 print_buffer_pos_byte = 0; \
163 if (EQ (printcharfun, Qt) && ! noninteractive) \
164 setup_echo_area_for_printing (multibyte);
166 #define PRINTFINISH \
167 if (NILP (printcharfun)) \
169 if (print_buffer_pos != print_buffer_pos_byte \
170 && NILP (BVAR (current_buffer, enable_multibyte_characters)))\
172 unsigned char *temp = alloca (print_buffer_pos + 1); \
173 copy_text ((unsigned char *) print_buffer, temp, \
174 print_buffer_pos_byte, 1, 0); \
175 insert_1_both ((char *) temp, print_buffer_pos, \
176 print_buffer_pos, 0, 1, 0); \
179 insert_1_both (print_buffer, print_buffer_pos, \
180 print_buffer_pos_byte, 0, 1, 0); \
181 signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
183 if (free_print_buffer) \
185 xfree (print_buffer); \
188 unbind_to (specpdl_count, Qnil); \
189 if (MARKERP (original)) \
190 set_marker_both (original, Qnil, PT, PT_BYTE); \
191 if (old_point >= 0) \
192 SET_PT_BOTH (old_point + (old_point >= start_point \
193 ? PT - start_point : 0), \
194 old_point_byte + (old_point_byte >= start_point_byte \
195 ? PT_BYTE - start_point_byte : 0)); \
196 set_buffer_internal (old);
198 #define PRINTCHAR(ch) printchar (ch, printcharfun)
200 /* This is used to restore the saved contents of print_buffer
201 when there is a recursive call to print. */
204 print_unwind (Lisp_Object saved_text
)
206 memcpy (print_buffer
, SDATA (saved_text
), SCHARS (saved_text
));
210 /* Print character CH using method FUN. FUN nil means print to
211 print_buffer. FUN t means print to echo area or stdout if
212 non-interactive. If FUN is neither nil nor t, call FUN with CH as
216 printchar (unsigned int ch
, Lisp_Object fun
)
218 if (!NILP (fun
) && !EQ (fun
, Qt
))
219 call1 (fun
, make_number (ch
));
222 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
223 int len
= CHAR_STRING (ch
, str
);
229 ptrdiff_t incr
= len
- (print_buffer_size
- print_buffer_pos_byte
);
231 print_buffer
= xpalloc (print_buffer
, &print_buffer_size
,
233 memcpy (print_buffer
+ print_buffer_pos_byte
, str
, len
);
234 print_buffer_pos
+= 1;
235 print_buffer_pos_byte
+= len
;
237 else if (noninteractive
)
239 fwrite (str
, 1, len
, stdout
);
240 noninteractive_need_newline
= 1;
245 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
247 setup_echo_area_for_printing (multibyte_p
);
249 message_dolog ((char *) str
, len
, 0, multibyte_p
);
255 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
256 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
257 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
258 print_buffer. PRINTCHARFUN t means output to the echo area or to
259 stdout if non-interactive. If neither nil nor t, call Lisp
260 function PRINTCHARFUN for each character printed. MULTIBYTE
261 non-zero means PTR contains multibyte characters.
263 In the case where PRINTCHARFUN is nil, it is safe for PTR to point
264 to data in a Lisp string. Otherwise that is not safe. */
267 strout (const char *ptr
, ptrdiff_t size
, ptrdiff_t size_byte
,
268 Lisp_Object printcharfun
)
271 size_byte
= size
= strlen (ptr
);
273 if (NILP (printcharfun
))
275 ptrdiff_t incr
= size_byte
- (print_buffer_size
- print_buffer_pos_byte
);
277 print_buffer
= xpalloc (print_buffer
, &print_buffer_size
, incr
, -1, 1);
278 memcpy (print_buffer
+ print_buffer_pos_byte
, ptr
, size_byte
);
279 print_buffer_pos
+= size
;
280 print_buffer_pos_byte
+= size_byte
;
282 else if (noninteractive
&& EQ (printcharfun
, Qt
))
284 fwrite (ptr
, 1, size_byte
, stdout
);
285 noninteractive_need_newline
= 1;
287 else if (EQ (printcharfun
, Qt
))
289 /* Output to echo area. We're trying to avoid a little overhead
290 here, that's the reason we don't call printchar to do the
294 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
296 setup_echo_area_for_printing (multibyte_p
);
297 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
299 if (size
== size_byte
)
301 for (i
= 0; i
< size
; ++i
)
302 insert_char ((unsigned char) *ptr
++);
307 for (i
= 0; i
< size_byte
; i
+= len
)
309 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
317 /* PRINTCHARFUN is a Lisp function. */
320 if (size
== size_byte
)
322 while (i
< size_byte
)
330 while (i
< size_byte
)
332 /* Here, we must convert each multi-byte form to the
333 corresponding character code before handing it to
336 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
345 /* Print the contents of a string STRING using PRINTCHARFUN.
346 It isn't safe to use strout in many cases,
347 because printing one char can relocate. */
350 print_string (Lisp_Object string
, Lisp_Object printcharfun
)
352 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
356 if (print_escape_nonascii
)
357 string
= string_escape_byte8 (string
);
359 if (STRING_MULTIBYTE (string
))
360 chars
= SCHARS (string
);
361 else if (! print_escape_nonascii
362 && (EQ (printcharfun
, Qt
)
363 ? ! NILP (BVAR (&buffer_defaults
, enable_multibyte_characters
))
364 : ! NILP (BVAR (current_buffer
, enable_multibyte_characters
))))
366 /* If unibyte string STRING contains 8-bit codes, we must
367 convert STRING to a multibyte string containing the same
372 chars
= SBYTES (string
);
373 bytes
= count_size_as_multibyte (SDATA (string
), chars
);
376 newstr
= make_uninit_multibyte_string (chars
, bytes
);
377 memcpy (SDATA (newstr
), SDATA (string
), chars
);
378 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
383 chars
= SBYTES (string
);
385 if (EQ (printcharfun
, Qt
))
387 /* Output to echo area. */
388 ptrdiff_t nbytes
= SBYTES (string
);
390 /* Copy the string contents so that relocation of STRING by
391 GC does not cause trouble. */
393 char *buffer
= SAFE_ALLOCA (nbytes
);
394 memcpy (buffer
, SDATA (string
), nbytes
);
396 strout (buffer
, chars
, nbytes
, printcharfun
);
401 /* No need to copy, since output to print_buffer can't GC. */
402 strout (SSDATA (string
), chars
, SBYTES (string
), printcharfun
);
406 /* Otherwise, string may be relocated by printing one char.
407 So re-fetch the string address for each character. */
409 ptrdiff_t size
= SCHARS (string
);
410 ptrdiff_t size_byte
= SBYTES (string
);
413 if (size
== size_byte
)
414 for (i
= 0; i
< size
; i
++)
415 PRINTCHAR (SREF (string
, i
));
417 for (i
= 0; i
< size_byte
; )
419 /* Here, we must convert each multi-byte form to the
420 corresponding character code before handing it to PRINTCHAR. */
422 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
, len
);
430 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
431 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
432 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
433 (Lisp_Object character
, Lisp_Object printcharfun
)
437 if (NILP (printcharfun
))
438 printcharfun
= Vstandard_output
;
439 CHECK_NUMBER (character
);
441 PRINTCHAR (XINT (character
));
446 /* Used from outside of print.c to print a block of SIZE
447 single-byte chars at DATA on the default output stream.
448 Do not use this on the contents of a Lisp string. */
451 write_string (const char *data
, int size
)
454 Lisp_Object printcharfun
;
456 printcharfun
= Vstandard_output
;
459 strout (data
, size
, size
, printcharfun
);
463 /* Used to print a block of SIZE single-byte chars at DATA on a
464 specified stream PRINTCHARFUN.
465 Do not use this on the contents of a Lisp string. */
468 write_string_1 (const char *data
, int size
, Lisp_Object printcharfun
)
473 strout (data
, size
, size
, printcharfun
);
479 temp_output_buffer_setup (const char *bufname
)
481 ptrdiff_t count
= SPECPDL_INDEX ();
482 register struct buffer
*old
= current_buffer
;
483 register Lisp_Object buf
;
485 record_unwind_current_buffer ();
487 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
489 Fkill_all_local_variables ();
490 delete_all_overlays (current_buffer
);
491 bset_directory (current_buffer
, BVAR (old
, directory
));
492 bset_read_only (current_buffer
, Qnil
);
493 bset_filename (current_buffer
, Qnil
);
494 bset_undo_list (current_buffer
, Qt
);
495 eassert (current_buffer
->overlays_before
== NULL
);
496 eassert (current_buffer
->overlays_after
== NULL
);
497 bset_enable_multibyte_characters
498 (current_buffer
, BVAR (&buffer_defaults
, enable_multibyte_characters
));
499 specbind (Qinhibit_read_only
, Qt
);
500 specbind (Qinhibit_modification_hooks
, Qt
);
502 XSETBUFFER (buf
, current_buffer
);
504 Frun_hooks (1, &Qtemp_buffer_setup_hook
);
506 unbind_to (count
, Qnil
);
508 specbind (Qstandard_output
, buf
);
511 static void print (Lisp_Object
, Lisp_Object
, bool);
512 static void print_preprocess (Lisp_Object
);
513 static void print_preprocess_string (INTERVAL
, Lisp_Object
);
514 static void print_object (Lisp_Object
, Lisp_Object
, bool);
516 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
517 doc
: /* Output a newline to stream PRINTCHARFUN.
518 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
519 (Lisp_Object printcharfun
)
523 if (NILP (printcharfun
))
524 printcharfun
= Vstandard_output
;
531 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
532 doc
: /* Output the printed representation of OBJECT, any Lisp object.
533 Quoting characters are printed when needed to make output that `read'
534 can handle, whenever this is possible. For complex objects, the behavior
535 is controlled by `print-level' and `print-length', which see.
537 OBJECT is any of the Lisp data types: a number, a string, a symbol,
538 a list, a buffer, a window, a frame, etc.
540 A printed representation of an object is text which describes that object.
542 Optional argument PRINTCHARFUN is the output stream, which can be one
545 - a buffer, in which case output is inserted into that buffer at point;
546 - a marker, in which case output is inserted at marker's position;
547 - a function, in which case that function is called once for each
548 character of OBJECT's printed representation;
549 - a symbol, in which case that symbol's function definition is called; or
550 - t, in which case the output is displayed in the echo area.
552 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
554 (Lisp_Object object
, Lisp_Object printcharfun
)
558 if (NILP (printcharfun
))
559 printcharfun
= Vstandard_output
;
561 print (object
, printcharfun
, 1);
566 /* a buffer which is used to hold output being built by prin1-to-string */
567 Lisp_Object Vprin1_to_string_buffer
;
569 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
570 doc
: /* Return a string containing the printed representation of OBJECT.
571 OBJECT can be any Lisp object. This function outputs quoting characters
572 when necessary to make output that `read' can handle, whenever possible,
573 unless the optional second argument NOESCAPE is non-nil. For complex objects,
574 the behavior is controlled by `print-level' and `print-length', which see.
576 OBJECT is any of the Lisp data types: a number, a string, a symbol,
577 a list, a buffer, a window, a frame, etc.
579 A printed representation of an object is text which describes that object. */)
580 (Lisp_Object object
, Lisp_Object noescape
)
582 Lisp_Object printcharfun
;
583 bool prev_abort_on_gc
;
584 /* struct gcpro gcpro1, gcpro2; */
585 Lisp_Object save_deactivate_mark
;
586 ptrdiff_t count
= SPECPDL_INDEX ();
587 struct buffer
*previous
;
589 specbind (Qinhibit_modification_hooks
, Qt
);
594 /* Save and restore this--we are altering a buffer
595 but we don't want to deactivate the mark just for that.
596 No need for specbind, since errors deactivate the mark. */
597 save_deactivate_mark
= Vdeactivate_mark
;
598 /* GCPRO2 (object, save_deactivate_mark); */
599 prev_abort_on_gc
= abort_on_gc
;
602 printcharfun
= Vprin1_to_string_buffer
;
604 print (object
, printcharfun
, NILP (noescape
));
605 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINISH */
609 previous
= current_buffer
;
610 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
611 object
= Fbuffer_string ();
612 if (SBYTES (object
) == SCHARS (object
))
613 STRING_SET_UNIBYTE (object
);
615 /* Note that this won't make prepare_to_modify_buffer call
616 ask-user-about-supersession-threat because this buffer
617 does not visit a file. */
619 set_buffer_internal (previous
);
621 Vdeactivate_mark
= save_deactivate_mark
;
624 abort_on_gc
= prev_abort_on_gc
;
625 return unbind_to (count
, object
);
628 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
629 doc
: /* Output the printed representation of OBJECT, any Lisp object.
630 No quoting characters are used; no delimiters are printed around
631 the contents of strings.
633 OBJECT is any of the Lisp data types: a number, a string, a symbol,
634 a list, a buffer, a window, a frame, etc.
636 A printed representation of an object is text which describes that object.
638 Optional argument PRINTCHARFUN is the output stream, which can be one
641 - a buffer, in which case output is inserted into that buffer at point;
642 - a marker, in which case output is inserted at marker's position;
643 - a function, in which case that function is called once for each
644 character of OBJECT's printed representation;
645 - a symbol, in which case that symbol's function definition is called; or
646 - t, in which case the output is displayed in the echo area.
648 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
650 (Lisp_Object object
, Lisp_Object printcharfun
)
654 if (NILP (printcharfun
))
655 printcharfun
= Vstandard_output
;
657 print (object
, printcharfun
, 0);
662 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
663 doc
: /* Output the printed representation of OBJECT, with newlines around it.
664 Quoting characters are printed when needed to make output that `read'
665 can handle, whenever this is possible. For complex objects, the behavior
666 is controlled by `print-level' and `print-length', which see.
668 OBJECT is any of the Lisp data types: a number, a string, a symbol,
669 a list, a buffer, a window, a frame, etc.
671 A printed representation of an object is text which describes that object.
673 Optional argument PRINTCHARFUN is the output stream, which can be one
676 - a buffer, in which case output is inserted into that buffer at point;
677 - a marker, in which case output is inserted at marker's position;
678 - a function, in which case that function is called once for each
679 character of OBJECT's printed representation;
680 - a symbol, in which case that symbol's function definition is called; or
681 - t, in which case the output is displayed in the echo area.
683 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
685 (Lisp_Object object
, Lisp_Object printcharfun
)
690 if (NILP (printcharfun
))
691 printcharfun
= Vstandard_output
;
695 print (object
, printcharfun
, 1);
702 /* The subroutine object for external-debugging-output is kept here
703 for the convenience of the debugger. */
704 Lisp_Object Qexternal_debugging_output
;
706 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
707 doc
: /* Write CHARACTER to stderr.
708 You can call print while debugging emacs, and pass it this function
709 to make it write to the debugging output. */)
710 (Lisp_Object character
)
712 CHECK_NUMBER (character
);
713 putc (XINT (character
) & 0xFF, stderr
);
716 /* Send the output to a debugger (nothing happens if there isn't one). */
717 if (print_output_debug_flag
)
719 char buf
[2] = {(char) XINT (character
), '\0'};
720 OutputDebugString (buf
);
727 /* This function is never called. Its purpose is to prevent
728 print_output_debug_flag from being optimized away. */
730 extern void debug_output_compilation_hack (bool) EXTERNALLY_VISIBLE
;
732 debug_output_compilation_hack (bool x
)
734 print_output_debug_flag
= x
;
737 #if defined (GNU_LINUX)
739 /* This functionality is not vitally important in general, so we rely on
740 non-portable ability to use stderr as lvalue. */
742 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
744 static FILE *initial_stderr_stream
= NULL
;
746 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
748 "FDebug output file: \nP",
749 doc
: /* Redirect debugging output (stderr stream) to file FILE.
750 If FILE is nil, reset target to the initial stderr stream.
751 Optional arg APPEND non-nil (interactively, with prefix arg) means
752 append to existing target file. */)
753 (Lisp_Object file
, Lisp_Object append
)
755 if (initial_stderr_stream
!= NULL
)
761 stderr
= initial_stderr_stream
;
762 initial_stderr_stream
= NULL
;
766 file
= Fexpand_file_name (file
, Qnil
);
767 initial_stderr_stream
= stderr
;
768 stderr
= emacs_fopen (SSDATA (file
), NILP (append
) ? "w" : "a");
771 stderr
= initial_stderr_stream
;
772 initial_stderr_stream
= NULL
;
773 report_file_error ("Cannot open debugging output stream", file
);
778 #endif /* GNU_LINUX */
781 /* This is the interface for debugging printing. */
784 debug_print (Lisp_Object arg
)
786 Fprin1 (arg
, Qexternal_debugging_output
);
787 fprintf (stderr
, "\r\n");
790 void safe_debug_print (Lisp_Object
) EXTERNALLY_VISIBLE
;
792 safe_debug_print (Lisp_Object arg
)
794 int valid
= valid_lisp_object_p (arg
);
799 fprintf (stderr
, "#<%s_LISP_OBJECT 0x%08"pI
"x>\r\n",
800 !valid
? "INVALID" : "SOME",
805 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
807 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
808 See Info anchor `(elisp)Definition of signal' for some details on how this
809 error message is constructed. */)
812 struct buffer
*old
= current_buffer
;
816 /* If OBJ is (error STRING), just return STRING.
817 That is not only faster, it also avoids the need to allocate
818 space here when the error is due to memory full. */
819 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
820 && CONSP (XCDR (obj
))
821 && STRINGP (XCAR (XCDR (obj
)))
822 && NILP (XCDR (XCDR (obj
))))
823 return XCAR (XCDR (obj
));
825 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
827 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
828 value
= Fbuffer_string ();
832 set_buffer_internal (old
);
838 /* Print an error message for the error DATA onto Lisp output stream
839 STREAM (suitable for the print functions).
840 CONTEXT is a C string describing the context of the error.
841 CALLER is the Lisp function inside which the error was signaled. */
844 print_error_message (Lisp_Object data
, Lisp_Object stream
, const char *context
,
847 Lisp_Object errname
, errmsg
, file_error
, tail
;
851 write_string_1 (context
, -1, stream
);
853 /* If we know from where the error was signaled, show it in
855 if (!NILP (caller
) && SYMBOLP (caller
))
857 Lisp_Object cname
= SYMBOL_NAME (caller
);
858 ptrdiff_t cnamelen
= SBYTES (cname
);
860 char *name
= SAFE_ALLOCA (cnamelen
);
861 memcpy (name
, SDATA (cname
), cnamelen
);
862 message_dolog (name
, cnamelen
, 0, 0);
863 message_dolog (": ", 2, 0, 0);
867 errname
= Fcar (data
);
869 if (EQ (errname
, Qerror
))
874 errmsg
= Fcar (data
);
879 Lisp_Object error_conditions
= Fget (errname
, Qerror_conditions
);
880 errmsg
= Fget (errname
, Qerror_message
);
881 file_error
= Fmemq (Qfile_error
, error_conditions
);
884 /* Print an error message including the data items. */
886 tail
= Fcdr_safe (data
);
889 /* For file-error, make error message by concatenating
890 all the data items. They are all strings. */
891 if (!NILP (file_error
) && CONSP (tail
))
892 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
895 const char *sep
= ": ";
897 if (!STRINGP (errmsg
))
898 write_string_1 ("peculiar error", -1, stream
);
899 else if (SCHARS (errmsg
))
900 Fprinc (errmsg
, stream
);
904 for (; CONSP (tail
); tail
= XCDR (tail
), sep
= ", ")
909 write_string_1 (sep
, 2, stream
);
911 if (!NILP (file_error
)
912 || EQ (errname
, Qend_of_file
) || EQ (errname
, Quser_error
))
913 Fprinc (obj
, stream
);
915 Fprin1 (obj
, stream
);
925 * The buffer should be at least as large as the max string size of the
926 * largest float, printed in the biggest notation. This is undoubtedly
927 * 20d float_output_format, with the negative of the C-constant "HUGE"
930 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
932 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
933 * case of -1e307 in 20d float_output_format. What is one to do (short of
934 * re-writing _doprnt to be more sane)?
936 * Given the above, the buffer must be least FLOAT_TO_STRING_BUFSIZE bytes.
940 float_to_string (char *buf
, double data
)
946 /* Check for plus infinity in a way that won't lose
947 if there is no plus infinity. */
948 if (data
== data
/ 2 && data
> 1.0)
950 static char const infinity_string
[] = "1.0e+INF";
951 strcpy (buf
, infinity_string
);
952 return sizeof infinity_string
- 1;
954 /* Likewise for minus infinity. */
955 if (data
== data
/ 2 && data
< -1.0)
957 static char const minus_infinity_string
[] = "-1.0e+INF";
958 strcpy (buf
, minus_infinity_string
);
959 return sizeof minus_infinity_string
- 1;
961 /* Check for NaN in a way that won't fail if there are no NaNs. */
962 if (! (data
* 0.0 >= 0.0))
964 /* Prepend "-" if the NaN's sign bit is negative.
965 The sign bit of a double is the bit that is 1 in -0.0. */
966 static char const NaN_string
[] = "0.0e+NaN";
968 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
971 u_minus_zero
.d
= - 0.0;
972 for (i
= 0; i
< sizeof (double); i
++)
973 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
980 strcpy (buf
+ negative
, NaN_string
);
981 return negative
+ sizeof NaN_string
- 1;
984 if (NILP (Vfloat_output_format
)
985 || !STRINGP (Vfloat_output_format
))
988 /* Generate the fewest number of digits that represent the
989 floating point value without losing information. */
990 len
= dtoastr (buf
, FLOAT_TO_STRING_BUFSIZE
- 2, 0, 0, data
);
991 /* The decimal point must be printed, or the byte compiler can
992 get confused (Bug#8033). */
997 /* Check that the spec we have is fully valid.
998 This means not only valid for printf,
999 but meant for floats, and reasonable. */
1000 cp
= SSDATA (Vfloat_output_format
);
1009 /* Check the width specification. */
1011 if ('0' <= *cp
&& *cp
<= '9')
1016 width
= (width
* 10) + (*cp
++ - '0');
1017 if (DBL_DIG
< width
)
1020 while (*cp
>= '0' && *cp
<= '9');
1022 /* A precision of zero is valid only for %f. */
1023 if (width
== 0 && *cp
!= 'f')
1027 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1033 len
= sprintf (buf
, SSDATA (Vfloat_output_format
), data
);
1036 /* Make sure there is a decimal point with digit after, or an
1037 exponent, so that the value is readable as a float. But don't do
1038 this with "%.0f"; it's valid for that not to produce a decimal
1039 point. Note that width can be 0 only for %.0f. */
1042 for (cp
= buf
; *cp
; cp
++)
1043 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1046 if (*cp
== '.' && cp
[1] == 0)
1066 print (Lisp_Object obj
, Lisp_Object printcharfun
, bool escapeflag
)
1068 new_backquote_output
= 0;
1070 /* Reset print_number_index and Vprint_number_table only when
1071 the variable Vprint_continuous_numbering is nil. Otherwise,
1072 the values of these variables will be kept between several
1074 if (NILP (Vprint_continuous_numbering
)
1075 || NILP (Vprint_number_table
))
1077 print_number_index
= 0;
1078 Vprint_number_table
= Qnil
;
1081 /* Construct Vprint_number_table for print-gensym and print-circle. */
1082 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1084 /* Construct Vprint_number_table.
1085 This increments print_number_index for the objects added. */
1087 print_preprocess (obj
);
1089 if (HASH_TABLE_P (Vprint_number_table
))
1090 { /* Remove unnecessary objects, which appear only once in OBJ;
1091 that is, whose status is Qt. */
1092 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vprint_number_table
);
1095 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
1096 if (!NILP (HASH_HASH (h
, i
))
1097 && EQ (HASH_VALUE (h
, i
), Qt
))
1098 Fremhash (HASH_KEY (h
, i
), Vprint_number_table
);
1103 print_object (obj
, printcharfun
, escapeflag
);
1106 #define PRINT_CIRCLE_CANDIDATE_P(obj) \
1107 (STRINGP (obj) || CONSP (obj) \
1108 || (VECTORLIKEP (obj) \
1109 && (VECTORP (obj) || COMPILEDP (obj) \
1110 || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \
1111 || HASH_TABLE_P (obj) || FONTP (obj))) \
1112 || (! NILP (Vprint_gensym) \
1114 && !SYMBOL_INTERNED_P (obj)))
1116 /* Construct Vprint_number_table according to the structure of OBJ.
1117 OBJ itself and all its elements will be added to Vprint_number_table
1118 recursively if it is a list, vector, compiled function, char-table,
1119 string (its text properties will be traced), or a symbol that has
1120 no obarray (this is for the print-gensym feature).
1121 The status fields of Vprint_number_table mean whether each object appears
1122 more than once in OBJ: Qnil at the first time, and Qt after that. */
1124 print_preprocess (Lisp_Object obj
)
1129 Lisp_Object halftail
;
1131 /* Avoid infinite recursion for circular nested structure
1132 in the case where Vprint_circle is nil. */
1133 if (NILP (Vprint_circle
))
1135 /* Give up if we go so deep that print_object will get an error. */
1136 /* See similar code in print_object. */
1137 if (print_depth
>= PRINT_CIRCLE
)
1138 error ("Apparently circular structure being printed");
1140 for (i
= 0; i
< print_depth
; i
++)
1141 if (EQ (obj
, being_printed
[i
]))
1143 being_printed
[print_depth
] = obj
;
1150 if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1152 if (!HASH_TABLE_P (Vprint_number_table
))
1154 Lisp_Object args
[2];
1157 Vprint_number_table
= Fmake_hash_table (2, args
);
1160 /* In case print-circle is nil and print-gensym is t,
1161 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1162 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1164 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1166 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1167 always print the gensym with a number. This is a special for
1168 the lisp function byte-compile-output-docform. */
1169 || (!NILP (Vprint_continuous_numbering
)
1171 && !SYMBOL_INTERNED_P (obj
)))
1172 { /* OBJ appears more than once. Let's remember that. */
1173 if (!INTEGERP (num
))
1175 print_number_index
++;
1176 /* Negative number indicates it hasn't been printed yet. */
1177 Fputhash (obj
, make_number (- print_number_index
),
1178 Vprint_number_table
);
1184 /* OBJ is not yet recorded. Let's add to the table. */
1185 Fputhash (obj
, Qt
, Vprint_number_table
);
1188 switch (XTYPE (obj
))
1191 /* A string may have text properties, which can be circular. */
1192 traverse_intervals_noorder (string_intervals (obj
),
1193 print_preprocess_string
, Qnil
);
1197 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1198 just as in print_object. */
1199 if (loop_count
&& EQ (obj
, halftail
))
1201 print_preprocess (XCAR (obj
));
1204 if (!(loop_count
& 1))
1205 halftail
= XCDR (halftail
);
1208 case Lisp_Vectorlike
:
1210 if (size
& PSEUDOVECTOR_FLAG
)
1211 size
&= PSEUDOVECTOR_SIZE_MASK
;
1212 for (i
= 0; i
< size
; i
++)
1213 print_preprocess (AREF (obj
, i
));
1214 if (HASH_TABLE_P (obj
))
1215 { /* For hash tables, the key_and_value slot is past
1216 `size' because it needs to be marked specially in case
1217 the table is weak. */
1218 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1219 print_preprocess (h
->key_and_value
);
1231 print_preprocess_string (INTERVAL interval
, Lisp_Object arg
)
1233 print_preprocess (interval
->plist
);
1236 static void print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
);
1238 #define PRINT_STRING_NON_CHARSET_FOUND 1
1239 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1241 /* Bitwise or of the above macros. */
1242 static int print_check_string_result
;
1245 print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
)
1249 if (NILP (interval
->plist
)
1250 || (print_check_string_result
== (PRINT_STRING_NON_CHARSET_FOUND
1251 | PRINT_STRING_UNSAFE_CHARSET_FOUND
)))
1253 for (val
= interval
->plist
; CONSP (val
) && ! EQ (XCAR (val
), Qcharset
);
1254 val
= XCDR (XCDR (val
)));
1257 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1260 if (! (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
))
1262 if (! EQ (val
, interval
->plist
)
1263 || CONSP (XCDR (XCDR (val
))))
1264 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1266 if (NILP (Vprint_charset_text_property
)
1267 || ! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1270 ptrdiff_t charpos
= interval
->position
;
1271 ptrdiff_t bytepos
= string_char_to_byte (string
, charpos
);
1272 Lisp_Object charset
;
1274 charset
= XCAR (XCDR (val
));
1275 for (i
= 0; i
< LENGTH (interval
); i
++)
1277 FETCH_STRING_CHAR_ADVANCE (c
, string
, charpos
, bytepos
);
1278 if (! ASCII_CHAR_P (c
)
1279 && ! EQ (CHARSET_NAME (CHAR_CHARSET (c
)), charset
))
1281 print_check_string_result
|= PRINT_STRING_UNSAFE_CHARSET_FOUND
;
1288 /* The value is (charset . nil). */
1289 static Lisp_Object print_prune_charset_plist
;
1292 print_prune_string_charset (Lisp_Object string
)
1294 print_check_string_result
= 0;
1295 traverse_intervals (string_intervals (string
), 0,
1296 print_check_string_charset_prop
, string
);
1297 if (! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1299 string
= Fcopy_sequence (string
);
1300 if (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
)
1302 if (NILP (print_prune_charset_plist
))
1303 print_prune_charset_plist
= list1 (Qcharset
);
1304 Fremove_text_properties (make_number (0),
1305 make_number (SCHARS (string
)),
1306 print_prune_charset_plist
, string
);
1309 Fset_text_properties (make_number (0), make_number (SCHARS (string
)),
1316 print_object (Lisp_Object obj
, Lisp_Object printcharfun
, bool escapeflag
)
1318 char buf
[max (sizeof "from..to..in " + 2 * INT_STRLEN_BOUND (EMACS_INT
),
1319 max (sizeof " . #" + INT_STRLEN_BOUND (printmax_t
),
1324 /* Detect circularities and truncate them. */
1325 if (NILP (Vprint_circle
))
1327 /* Simple but incomplete way. */
1330 /* See similar code in print_preprocess. */
1331 if (print_depth
>= PRINT_CIRCLE
)
1332 error ("Apparently circular structure being printed");
1334 for (i
= 0; i
< print_depth
; i
++)
1335 if (EQ (obj
, being_printed
[i
]))
1337 int len
= sprintf (buf
, "#%d", i
);
1338 strout (buf
, len
, len
, printcharfun
);
1341 being_printed
[print_depth
] = obj
;
1343 else if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1345 /* With the print-circle feature. */
1346 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1349 EMACS_INT n
= XINT (num
);
1351 { /* Add a prefix #n= if OBJ has not yet been printed;
1352 that is, its status field is nil. */
1353 int len
= sprintf (buf
, "#%"pI
"d=", -n
);
1354 strout (buf
, len
, len
, printcharfun
);
1355 /* OBJ is going to be printed. Remember that fact. */
1356 Fputhash (obj
, make_number (- n
), Vprint_number_table
);
1360 /* Just print #n# if OBJ has already been printed. */
1361 int len
= sprintf (buf
, "#%"pI
"d#", n
);
1362 strout (buf
, len
, len
, printcharfun
);
1370 switch (XTYPE (obj
))
1374 int len
= sprintf (buf
, "%"pI
"d", XINT (obj
));
1375 strout (buf
, len
, len
, printcharfun
);
1381 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
1382 int len
= float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1383 strout (pigbuf
, len
, len
, printcharfun
);
1389 print_string (obj
, printcharfun
);
1392 register ptrdiff_t i
, i_byte
;
1393 struct gcpro gcpro1
;
1394 ptrdiff_t size_byte
;
1395 /* 1 means we must ensure that the next character we output
1396 cannot be taken as part of a hex character escape. */
1397 bool need_nonhex
= 0;
1398 bool multibyte
= STRING_MULTIBYTE (obj
);
1402 if (! EQ (Vprint_charset_text_property
, Qt
))
1403 obj
= print_prune_string_charset (obj
);
1405 if (string_intervals (obj
))
1412 size_byte
= SBYTES (obj
);
1414 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1416 /* Here, we must convert each multi-byte form to the
1417 corresponding character code before handing it to PRINTCHAR. */
1420 FETCH_STRING_CHAR_ADVANCE (c
, obj
, i
, i_byte
);
1424 if (c
== '\n' && print_escape_newlines
)
1429 else if (c
== '\f' && print_escape_newlines
)
1435 && (CHAR_BYTE8_P (c
)
1436 || (! ASCII_CHAR_P (c
) && print_escape_multibyte
)))
1438 /* When multibyte is disabled,
1439 print multibyte string chars using hex escapes.
1440 For a char code that could be in a unibyte string,
1441 when found in a multibyte string, always use a hex escape
1442 so it reads back as multibyte. */
1446 if (CHAR_BYTE8_P (c
))
1447 len
= sprintf (outbuf
, "\\%03o", CHAR_TO_BYTE8 (c
));
1450 len
= sprintf (outbuf
, "\\x%04x", c
);
1453 strout (outbuf
, len
, len
, printcharfun
);
1455 else if (! multibyte
1456 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1457 && print_escape_nonascii
)
1459 /* When printing in a multibyte buffer
1460 or when explicitly requested,
1461 print single-byte non-ASCII string chars
1462 using octal escapes. */
1464 int len
= sprintf (outbuf
, "\\%03o", c
);
1465 strout (outbuf
, len
, len
, printcharfun
);
1469 /* If we just had a hex escape, and this character
1470 could be taken as part of it,
1471 output `\ ' to prevent that. */
1475 if ((c
>= 'a' && c
<= 'f')
1476 || (c
>= 'A' && c
<= 'F')
1477 || (c
>= '0' && c
<= '9'))
1478 strout ("\\ ", -1, -1, printcharfun
);
1481 if (c
== '\"' || c
== '\\')
1488 if (string_intervals (obj
))
1490 traverse_intervals (string_intervals (obj
),
1491 0, print_interval
, printcharfun
);
1502 unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1503 unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1505 ptrdiff_t i
, i_byte
;
1506 ptrdiff_t size_byte
;
1509 name
= SYMBOL_NAME (obj
);
1511 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1514 /* If symbol name begins with a digit, and ends with a digit,
1515 and contains nothing but digits and `e', it could be treated
1516 as a number. So set CONFUSING.
1518 Symbols that contain periods could also be taken as numbers,
1519 but periods are always escaped, so we don't have to worry
1521 else if (*p
>= '0' && *p
<= '9'
1522 && end
[-1] >= '0' && end
[-1] <= '9')
1524 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1525 /* Needed for \2e10. */
1526 || *p
== 'e' || *p
== 'E'))
1528 confusing
= (end
== p
);
1533 size_byte
= SBYTES (name
);
1535 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1540 else if (size_byte
== 0)
1547 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1549 /* Here, we must convert each multi-byte form to the
1550 corresponding character code before handing it to PRINTCHAR. */
1551 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1556 if (c
== '\"' || c
== '\\' || c
== '\''
1557 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1558 || c
== ',' || c
== '.' || c
== '`'
1559 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1561 PRINTCHAR ('\\'), confusing
= 0;
1569 /* If deeper than spec'd depth, print placeholder. */
1570 if (INTEGERP (Vprint_level
)
1571 && print_depth
> XINT (Vprint_level
))
1572 strout ("...", -1, -1, printcharfun
);
1573 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1574 && (EQ (XCAR (obj
), Qquote
)))
1577 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1579 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1580 && (EQ (XCAR (obj
), Qfunction
)))
1584 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1586 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1587 && ((EQ (XCAR (obj
), Qbackquote
))))
1589 print_object (XCAR (obj
), printcharfun
, 0);
1590 new_backquote_output
++;
1591 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1592 new_backquote_output
--;
1594 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1595 && new_backquote_output
1596 && ((EQ (XCAR (obj
), Qbackquote
)
1597 || EQ (XCAR (obj
), Qcomma
)
1598 || EQ (XCAR (obj
), Qcomma_at
)
1599 || EQ (XCAR (obj
), Qcomma_dot
))))
1601 print_object (XCAR (obj
), printcharfun
, 0);
1602 new_backquote_output
--;
1603 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1604 new_backquote_output
++;
1611 printmax_t i
, print_length
;
1612 Lisp_Object halftail
= obj
;
1614 /* Negative values of print-length are invalid in CL.
1615 Treat them like nil, as CMUCL does. */
1616 if (NATNUMP (Vprint_length
))
1617 print_length
= XFASTINT (Vprint_length
);
1619 print_length
= TYPE_MAXIMUM (printmax_t
);
1624 /* Detect circular list. */
1625 if (NILP (Vprint_circle
))
1627 /* Simple but incomplete way. */
1628 if (i
!= 0 && EQ (obj
, halftail
))
1630 int len
= sprintf (buf
, " . #%"pMd
, i
/ 2);
1631 strout (buf
, len
, len
, printcharfun
);
1637 /* With the print-circle feature. */
1640 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1643 strout (" . ", 3, 3, printcharfun
);
1644 print_object (obj
, printcharfun
, escapeflag
);
1653 if (print_length
<= i
)
1655 strout ("...", 3, 3, printcharfun
);
1660 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1664 halftail
= XCDR (halftail
);
1668 /* OBJ non-nil here means it's the end of a dotted list. */
1671 strout (" . ", 3, 3, printcharfun
);
1672 print_object (obj
, printcharfun
, escapeflag
);
1680 case Lisp_Vectorlike
:
1685 strout ("#<process ", -1, -1, printcharfun
);
1686 print_string (XPROCESS (obj
)->name
, printcharfun
);
1690 print_string (XPROCESS (obj
)->name
, printcharfun
);
1692 else if (BOOL_VECTOR_P (obj
))
1697 struct gcpro gcpro1
;
1698 EMACS_INT size
= bool_vector_size (obj
);
1699 ptrdiff_t size_in_chars
= bool_vector_bytes (size
);
1700 ptrdiff_t real_size_in_chars
= size_in_chars
;
1705 len
= sprintf (buf
, "%"pI
"d", size
);
1706 strout (buf
, len
, len
, printcharfun
);
1709 /* Don't print more characters than the specified maximum.
1710 Negative values of print-length are invalid. Treat them
1711 like a print-length of nil. */
1712 if (NATNUMP (Vprint_length
)
1713 && XFASTINT (Vprint_length
) < size_in_chars
)
1714 size_in_chars
= XFASTINT (Vprint_length
);
1716 for (i
= 0; i
< size_in_chars
; i
++)
1719 c
= bool_vector_uchar_data (obj
)[i
];
1720 if (c
== '\n' && print_escape_newlines
)
1725 else if (c
== '\f' && print_escape_newlines
)
1730 else if (c
> '\177')
1732 /* Use octal escapes to avoid encoding issues. */
1734 PRINTCHAR ('0' + ((c
>> 6) & 3));
1735 PRINTCHAR ('0' + ((c
>> 3) & 7));
1736 PRINTCHAR ('0' + (c
& 7));
1740 if (c
== '\"' || c
== '\\')
1746 if (size_in_chars
< real_size_in_chars
)
1747 strout (" ...", 4, 4, printcharfun
);
1752 else if (SUBRP (obj
))
1754 strout ("#<subr ", -1, -1, printcharfun
);
1755 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
);
1758 else if (WINDOWP (obj
))
1761 strout ("#<window ", -1, -1, printcharfun
);
1762 len
= sprintf (buf
, "%d", XWINDOW (obj
)->sequence_number
);
1763 strout (buf
, len
, len
, printcharfun
);
1764 if (BUFFERP (XWINDOW (obj
)->contents
))
1766 strout (" on ", -1, -1, printcharfun
);
1767 print_string (BVAR (XBUFFER (XWINDOW (obj
)->contents
), name
),
1772 else if (TERMINALP (obj
))
1775 struct terminal
*t
= XTERMINAL (obj
);
1776 strout ("#<terminal ", -1, -1, printcharfun
);
1777 len
= sprintf (buf
, "%d", t
->id
);
1778 strout (buf
, len
, len
, printcharfun
);
1781 strout (" on ", -1, -1, printcharfun
);
1782 strout (t
->name
, -1, -1, printcharfun
);
1786 else if (HASH_TABLE_P (obj
))
1788 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1790 ptrdiff_t real_size
, size
;
1794 strout ("#<hash-table", -1, -1, printcharfun
);
1795 if (SYMBOLP (h
->test
))
1799 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
);
1801 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
);
1803 len
= sprintf (buf
, "%"pD
"d/%"pD
"d", h
->count
, ASIZE (h
->next
));
1804 strout (buf
, len
, len
, printcharfun
);
1806 len
= sprintf (buf
, " %p>", ptr
);
1807 strout (buf
, len
, len
, printcharfun
);
1809 /* Implement a readable output, e.g.:
1810 #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
1811 /* Always print the size. */
1812 len
= sprintf (buf
, "#s(hash-table size %"pD
"d", ASIZE (h
->next
));
1813 strout (buf
, len
, len
, printcharfun
);
1815 if (!NILP (h
->test
.name
))
1817 strout (" test ", -1, -1, printcharfun
);
1818 print_object (h
->test
.name
, printcharfun
, escapeflag
);
1821 if (!NILP (h
->weak
))
1823 strout (" weakness ", -1, -1, printcharfun
);
1824 print_object (h
->weak
, printcharfun
, escapeflag
);
1827 if (!NILP (h
->rehash_size
))
1829 strout (" rehash-size ", -1, -1, printcharfun
);
1830 print_object (h
->rehash_size
, printcharfun
, escapeflag
);
1833 if (!NILP (h
->rehash_threshold
))
1835 strout (" rehash-threshold ", -1, -1, printcharfun
);
1836 print_object (h
->rehash_threshold
, printcharfun
, escapeflag
);
1839 strout (" data ", -1, -1, printcharfun
);
1841 /* Print the data here as a plist. */
1842 real_size
= HASH_TABLE_SIZE (h
);
1845 /* Don't print more elements than the specified maximum. */
1846 if (NATNUMP (Vprint_length
)
1847 && XFASTINT (Vprint_length
) < size
)
1848 size
= XFASTINT (Vprint_length
);
1851 for (i
= 0; i
< size
; i
++)
1852 if (!NILP (HASH_HASH (h
, i
)))
1854 if (i
) PRINTCHAR (' ');
1855 print_object (HASH_KEY (h
, i
), printcharfun
, escapeflag
);
1857 print_object (HASH_VALUE (h
, i
), printcharfun
, escapeflag
);
1860 if (size
< real_size
)
1861 strout (" ...", 4, 4, printcharfun
);
1867 else if (BUFFERP (obj
))
1869 if (!BUFFER_LIVE_P (XBUFFER (obj
)))
1870 strout ("#<killed buffer>", -1, -1, printcharfun
);
1871 else if (escapeflag
)
1873 strout ("#<buffer ", -1, -1, printcharfun
);
1874 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1878 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1880 else if (WINDOW_CONFIGURATIONP (obj
))
1882 strout ("#<window-configuration>", -1, -1, printcharfun
);
1884 else if (FRAMEP (obj
))
1887 void *ptr
= XFRAME (obj
);
1888 Lisp_Object frame_name
= XFRAME (obj
)->name
;
1890 strout ((FRAME_LIVE_P (XFRAME (obj
))
1891 ? "#<frame " : "#<dead frame "),
1892 -1, -1, printcharfun
);
1893 if (!STRINGP (frame_name
))
1895 /* A frame could be too young and have no name yet;
1897 if (SYMBOLP (frame_name
))
1898 frame_name
= Fsymbol_name (frame_name
);
1899 else /* can't happen: name should be either nil or string */
1900 frame_name
= build_string ("*INVALID*FRAME*NAME*");
1902 print_string (frame_name
, printcharfun
);
1903 len
= sprintf (buf
, " %p>", ptr
);
1904 strout (buf
, len
, len
, printcharfun
);
1906 else if (FONTP (obj
))
1910 if (! FONT_OBJECT_P (obj
))
1912 if (FONT_SPEC_P (obj
))
1913 strout ("#<font-spec", -1, -1, printcharfun
);
1915 strout ("#<font-entity", -1, -1, printcharfun
);
1916 for (i
= 0; i
< FONT_SPEC_MAX
; i
++)
1919 if (i
< FONT_WEIGHT_INDEX
|| i
> FONT_WIDTH_INDEX
)
1920 print_object (AREF (obj
, i
), printcharfun
, escapeflag
);
1922 print_object (font_style_symbolic (obj
, i
, 0),
1923 printcharfun
, escapeflag
);
1928 strout ("#<font-object ", -1, -1, printcharfun
);
1929 print_object (AREF (obj
, FONT_NAME_INDEX
), printcharfun
,
1936 ptrdiff_t size
= ASIZE (obj
);
1937 if (COMPILEDP (obj
))
1940 size
&= PSEUDOVECTOR_SIZE_MASK
;
1942 if (CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
))
1944 /* We print a char-table as if it were a vector,
1945 lumping the parent and default slots in with the
1946 character slots. But we add #^ as a prefix. */
1948 /* Make each lowest sub_char_table start a new line.
1949 Otherwise we'll make a line extremely long, which
1950 results in slow redisplay. */
1951 if (SUB_CHAR_TABLE_P (obj
)
1952 && XINT (XSUB_CHAR_TABLE (obj
)->depth
) == 3)
1956 if (SUB_CHAR_TABLE_P (obj
))
1958 size
&= PSEUDOVECTOR_SIZE_MASK
;
1960 if (size
& PSEUDOVECTOR_FLAG
)
1966 register Lisp_Object tem
;
1967 ptrdiff_t real_size
= size
;
1969 /* Don't print more elements than the specified maximum. */
1970 if (NATNUMP (Vprint_length
)
1971 && XFASTINT (Vprint_length
) < size
)
1972 size
= XFASTINT (Vprint_length
);
1974 for (i
= 0; i
< size
; i
++)
1976 if (i
) PRINTCHAR (' ');
1977 tem
= AREF (obj
, i
);
1978 print_object (tem
, printcharfun
, escapeflag
);
1980 if (size
< real_size
)
1981 strout (" ...", 4, 4, printcharfun
);
1988 switch (XMISCTYPE (obj
))
1990 case Lisp_Misc_Marker
:
1991 strout ("#<marker ", -1, -1, printcharfun
);
1992 /* Do you think this is necessary? */
1993 if (XMARKER (obj
)->insertion_type
!= 0)
1994 strout ("(moves after insertion) ", -1, -1, printcharfun
);
1995 if (! XMARKER (obj
)->buffer
)
1996 strout ("in no buffer", -1, -1, printcharfun
);
1999 int len
= sprintf (buf
, "at %"pD
"d", marker_position (obj
));
2000 strout (buf
, len
, len
, printcharfun
);
2001 strout (" in ", -1, -1, printcharfun
);
2002 print_string (BVAR (XMARKER (obj
)->buffer
, name
), printcharfun
);
2007 case Lisp_Misc_Overlay
:
2008 strout ("#<overlay ", -1, -1, printcharfun
);
2009 if (! XMARKER (OVERLAY_START (obj
))->buffer
)
2010 strout ("in no buffer", -1, -1, printcharfun
);
2013 int len
= sprintf (buf
, "from %"pD
"d to %"pD
"d in ",
2014 marker_position (OVERLAY_START (obj
)),
2015 marker_position (OVERLAY_END (obj
)));
2016 strout (buf
, len
, len
, printcharfun
);
2017 print_string (BVAR (XMARKER (OVERLAY_START (obj
))->buffer
, name
),
2023 /* Remaining cases shouldn't happen in normal usage, but let's
2024 print them anyway for the benefit of the debugger. */
2026 case Lisp_Misc_Free
:
2027 strout ("#<misc free cell>", -1, -1, printcharfun
);
2030 case Lisp_Misc_Save_Value
:
2033 struct Lisp_Save_Value
*v
= XSAVE_VALUE (obj
);
2035 strout ("#<save-value ", -1, -1, printcharfun
);
2037 if (v
->save_type
== SAVE_TYPE_MEMORY
)
2039 ptrdiff_t amount
= v
->data
[1].integer
;
2043 /* valid_lisp_object_p is reliable, so try to print up
2044 to 8 saved objects. This code is rarely used, so
2045 it's OK that valid_lisp_object_p is slow. */
2047 int limit
= min (amount
, 8);
2048 Lisp_Object
*area
= v
->data
[0].pointer
;
2050 i
= sprintf (buf
, "with %"pD
"d objects", amount
);
2051 strout (buf
, i
, i
, printcharfun
);
2053 for (i
= 0; i
< limit
; i
++)
2055 Lisp_Object maybe
= area
[i
];
2057 if (valid_lisp_object_p (maybe
) > 0)
2060 print_object (maybe
, printcharfun
, escapeflag
);
2063 strout (" <invalid>", -1, -1, printcharfun
);
2065 if (i
== limit
&& i
< amount
)
2066 strout (" ...", 4, 4, printcharfun
);
2068 #else /* not GC_MARK_STACK */
2070 /* There is no reliable way to determine whether the objects
2071 are initialized, so do not try to print them. */
2073 i
= sprintf (buf
, "with %"pD
"d objects", amount
);
2074 strout (buf
, i
, i
, printcharfun
);
2076 #endif /* GC_MARK_STACK */
2080 /* Print each slot according to its type. */
2082 for (index
= 0; index
< SAVE_VALUE_SLOTS
; index
++)
2087 switch (save_type (v
, index
))
2090 i
= sprintf (buf
, "<unused>");
2094 i
= sprintf (buf
, "<pointer %p>",
2095 v
->data
[index
].pointer
);
2098 case SAVE_FUNCPOINTER
:
2099 i
= sprintf (buf
, "<funcpointer %p>",
2100 ((void *) (intptr_t)
2101 v
->data
[index
].funcpointer
));
2105 i
= sprintf (buf
, "<integer %"pD
"d>",
2106 v
->data
[index
].integer
);
2110 print_object (v
->data
[index
].object
, printcharfun
,
2118 strout (buf
, i
, i
, printcharfun
);
2134 /* We're in trouble if this happens!
2135 Probably should just emacs_abort (). */
2136 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
);
2138 len
= sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2139 else if (VECTORLIKEP (obj
))
2140 len
= sprintf (buf
, "(PVEC 0x%08"pD
"x)", ASIZE (obj
));
2142 len
= sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2143 strout (buf
, len
, len
, printcharfun
);
2144 strout (" Save your buffers immediately and please report this bug>",
2145 -1, -1, printcharfun
);
2153 /* Print a description of INTERVAL using PRINTCHARFUN.
2154 This is part of printing a string that has text properties. */
2157 print_interval (INTERVAL interval
, Lisp_Object printcharfun
)
2159 if (NILP (interval
->plist
))
2162 print_object (make_number (interval
->position
), printcharfun
, 1);
2164 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2167 print_object (interval
->plist
, printcharfun
, 1);
2170 /* Initialize debug_print stuff early to have it working from the very
2174 init_print_once (void)
2176 DEFSYM (Qexternal_debugging_output
, "external-debugging-output");
2177 defsubr (&Sexternal_debugging_output
);
2181 syms_of_print (void)
2183 DEFSYM (Qtemp_buffer_setup_hook
, "temp-buffer-setup-hook");
2185 DEFVAR_LISP ("standard-output", Vstandard_output
,
2186 doc
: /* Output stream `print' uses by default for outputting a character.
2187 This may be any function of one argument.
2188 It may also be a buffer (output is inserted before point)
2189 or a marker (output is inserted and the marker is advanced)
2190 or the symbol t (output appears in the echo area). */);
2191 Vstandard_output
= Qt
;
2192 DEFSYM (Qstandard_output
, "standard-output");
2194 DEFVAR_LISP ("float-output-format", Vfloat_output_format
,
2195 doc
: /* The format descriptor string used to print floats.
2196 This is a %-spec like those accepted by `printf' in C,
2197 but with some restrictions. It must start with the two characters `%.'.
2198 After that comes an integer precision specification,
2199 and then a letter which controls the format.
2200 The letters allowed are `e', `f' and `g'.
2201 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2202 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2203 Use `g' to choose the shorter of those two formats for the number at hand.
2204 The precision in any of these cases is the number of digits following
2205 the decimal point. With `f', a precision of 0 means to omit the
2206 decimal point. 0 is not allowed with `e' or `g'.
2208 A value of nil means to use the shortest notation
2209 that represents the number without losing information. */);
2210 Vfloat_output_format
= Qnil
;
2211 DEFSYM (Qfloat_output_format
, "float-output-format");
2213 DEFVAR_LISP ("print-length", Vprint_length
,
2214 doc
: /* Maximum length of list to print before abbreviating.
2215 A value of nil means no limit. See also `eval-expression-print-length'. */);
2216 Vprint_length
= Qnil
;
2218 DEFVAR_LISP ("print-level", Vprint_level
,
2219 doc
: /* Maximum depth of list nesting to print before abbreviating.
2220 A value of nil means no limit. See also `eval-expression-print-level'. */);
2221 Vprint_level
= Qnil
;
2223 DEFVAR_BOOL ("print-escape-newlines", print_escape_newlines
,
2224 doc
: /* Non-nil means print newlines in strings as `\\n'.
2225 Also print formfeeds as `\\f'. */);
2226 print_escape_newlines
= 0;
2228 DEFVAR_BOOL ("print-escape-nonascii", print_escape_nonascii
,
2229 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2230 \(OOO is the octal representation of the character code.)
2231 Only single-byte characters are affected, and only in `prin1'.
2232 When the output goes in a multibyte buffer, this feature is
2233 enabled regardless of the value of the variable. */);
2234 print_escape_nonascii
= 0;
2236 DEFVAR_BOOL ("print-escape-multibyte", print_escape_multibyte
,
2237 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2238 \(XXXX is the hex representation of the character code.)
2239 This affects only `prin1'. */);
2240 print_escape_multibyte
= 0;
2242 DEFVAR_BOOL ("print-quoted", print_quoted
,
2243 doc
: /* Non-nil means print quoted forms with reader syntax.
2244 I.e., (quote foo) prints as 'foo, (function foo) as #'foo. */);
2247 DEFVAR_LISP ("print-gensym", Vprint_gensym
,
2248 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2249 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2250 When the uninterned symbol appears within a recursive data structure,
2251 and the symbol appears more than once, in addition use the #N# and #N=
2252 constructs as needed, so that multiple references to the same symbol are
2253 shared once again when the text is read back. */);
2254 Vprint_gensym
= Qnil
;
2256 DEFVAR_LISP ("print-circle", Vprint_circle
,
2257 doc
: /* Non-nil means print recursive structures using #N= and #N# syntax.
2258 If nil, printing proceeds recursively and may lead to
2259 `max-lisp-eval-depth' being exceeded or an error may occur:
2260 \"Apparently circular structure being printed.\" Also see
2261 `print-length' and `print-level'.
2262 If non-nil, shared substructures anywhere in the structure are printed
2263 with `#N=' before the first occurrence (in the order of the print
2264 representation) and `#N#' in place of each subsequent occurrence,
2265 where N is a positive decimal integer. */);
2266 Vprint_circle
= Qnil
;
2268 DEFVAR_LISP ("print-continuous-numbering", Vprint_continuous_numbering
,
2269 doc
: /* Non-nil means number continuously across print calls.
2270 This affects the numbers printed for #N= labels and #M# references.
2271 See also `print-circle', `print-gensym', and `print-number-table'.
2272 This variable should not be set with `setq'; bind it with a `let' instead. */);
2273 Vprint_continuous_numbering
= Qnil
;
2275 DEFVAR_LISP ("print-number-table", Vprint_number_table
,
2276 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2277 The Lisp printer uses this vector to detect Lisp objects referenced more
2280 When you bind `print-continuous-numbering' to t, you should probably
2281 also bind `print-number-table' to nil. This ensures that the value of
2282 `print-number-table' can be garbage-collected once the printing is
2283 done. If all elements of `print-number-table' are nil, it means that
2284 the printing done so far has not found any shared structure or objects
2285 that need to be recorded in the table. */);
2286 Vprint_number_table
= Qnil
;
2288 DEFVAR_LISP ("print-charset-text-property", Vprint_charset_text_property
,
2289 doc
: /* A flag to control printing of `charset' text property on printing a string.
2290 The value must be nil, t, or `default'.
2292 If the value is nil, don't print the text property `charset'.
2294 If the value is t, always print the text property `charset'.
2296 If the value is `default', print the text property `charset' only when
2297 the value is different from what is guessed in the current charset
2299 Vprint_charset_text_property
= Qdefault
;
2301 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2302 staticpro (&Vprin1_to_string_buffer
);
2305 defsubr (&Sprin1_to_string
);
2306 defsubr (&Serror_message_string
);
2310 defsubr (&Swrite_char
);
2311 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2312 defsubr (&Sredirect_debugging_output
);
2315 DEFSYM (Qprint_escape_newlines
, "print-escape-newlines");
2316 DEFSYM (Qprint_escape_multibyte
, "print-escape-multibyte");
2317 DEFSYM (Qprint_escape_nonascii
, "print-escape-nonascii");
2319 print_prune_charset_plist
= Qnil
;
2320 staticpro (&print_prune_charset_plist
);