1 /* Lisp object printing and output streams.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2013 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. */
42 Lisp_Object Qstandard_output
;
44 static Lisp_Object Qtemp_buffer_setup_hook
;
46 /* These are used to print like we read. */
48 static Lisp_Object Qfloat_output_format
;
53 /* Avoid actual stack overflow in print. */
54 static ptrdiff_t print_depth
;
56 /* Level of nesting inside outputting backquote in new style. */
57 static ptrdiff_t new_backquote_output
;
59 /* Detect most circularities to print finite output. */
60 #define PRINT_CIRCLE 200
61 static Lisp_Object being_printed
[PRINT_CIRCLE
];
63 /* When printing into a buffer, first we put the text in this
64 block, then insert it all at once. */
65 static char *print_buffer
;
67 /* Size allocated in print_buffer. */
68 static ptrdiff_t print_buffer_size
;
69 /* Chars stored in print_buffer. */
70 static ptrdiff_t print_buffer_pos
;
71 /* Bytes stored in print_buffer. */
72 static ptrdiff_t print_buffer_pos_byte
;
74 Lisp_Object Qprint_escape_newlines
;
75 static Lisp_Object Qprint_escape_multibyte
, Qprint_escape_nonascii
;
77 /* Vprint_number_table is a table, that keeps objects that are going to
78 be printed, to allow use of #n= and #n# to express sharing.
79 For any given object, the table can give the following values:
80 t the object will be printed only once.
81 -N the object will be printed several times and will take number N.
82 N the object has been printed so we can refer to it as #N#.
83 print_number_index holds the largest N already used.
84 N has to be striclty larger than 0 since we need to distinguish -N. */
85 static ptrdiff_t print_number_index
;
86 static void print_interval (INTERVAL interval
, Lisp_Object printcharfun
);
88 /* GDB resets this to zero on W32 to disable OutputDebugString calls. */
89 bool print_output_debug_flag EXTERNALLY_VISIBLE
= 1;
92 /* Low level output routines for characters and strings. */
94 /* Lisp functions to do output using a stream
95 must have the stream in a variable called printcharfun
96 and must start with PRINTPREPARE, end with PRINTFINISH,
97 and use PRINTDECLARE to declare common variables.
98 Use PRINTCHAR to output one character,
99 or call strout to output a block of characters. */
101 #define PRINTDECLARE \
102 struct buffer *old = current_buffer; \
103 ptrdiff_t old_point = -1, start_point = -1; \
104 ptrdiff_t old_point_byte = -1, start_point_byte = -1; \
105 ptrdiff_t specpdl_count = SPECPDL_INDEX (); \
106 bool free_print_buffer = 0; \
108 = !NILP (BVAR (current_buffer, enable_multibyte_characters)); \
111 #define PRINTPREPARE \
112 original = printcharfun; \
113 if (NILP (printcharfun)) printcharfun = Qt; \
114 if (BUFFERP (printcharfun)) \
116 if (XBUFFER (printcharfun) != current_buffer) \
117 Fset_buffer (printcharfun); \
118 printcharfun = Qnil; \
120 if (MARKERP (printcharfun)) \
122 ptrdiff_t marker_pos; \
123 if (! XMARKER (printcharfun)->buffer) \
124 error ("Marker does not point anywhere"); \
125 if (XMARKER (printcharfun)->buffer != current_buffer) \
126 set_buffer_internal (XMARKER (printcharfun)->buffer); \
127 marker_pos = marker_position (printcharfun); \
128 if (marker_pos < BEGV || marker_pos > ZV) \
129 error ("Marker is outside the accessible part of the buffer"); \
131 old_point_byte = PT_BYTE; \
132 SET_PT_BOTH (marker_pos, \
133 marker_byte_position (printcharfun)); \
135 start_point_byte = PT_BYTE; \
136 printcharfun = Qnil; \
138 if (NILP (printcharfun)) \
140 Lisp_Object string; \
141 if (NILP (BVAR (current_buffer, enable_multibyte_characters)) \
142 && ! print_escape_multibyte) \
143 specbind (Qprint_escape_multibyte, Qt); \
144 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)) \
145 && ! print_escape_nonascii) \
146 specbind (Qprint_escape_nonascii, Qt); \
147 if (print_buffer != 0) \
149 string = make_string_from_bytes (print_buffer, \
151 print_buffer_pos_byte); \
152 record_unwind_protect (print_unwind, string); \
156 int new_size = 1000; \
157 print_buffer = xmalloc (new_size); \
158 print_buffer_size = new_size; \
159 free_print_buffer = 1; \
161 print_buffer_pos = 0; \
162 print_buffer_pos_byte = 0; \
164 if (EQ (printcharfun, Qt) && ! noninteractive) \
165 setup_echo_area_for_printing (multibyte);
167 #define PRINTFINISH \
168 if (NILP (printcharfun)) \
170 if (print_buffer_pos != print_buffer_pos_byte \
171 && NILP (BVAR (current_buffer, enable_multibyte_characters))) \
173 unsigned char *temp = alloca (print_buffer_pos + 1); \
174 copy_text ((unsigned char *) print_buffer, temp, \
175 print_buffer_pos_byte, 1, 0); \
176 insert_1_both ((char *) temp, print_buffer_pos, \
177 print_buffer_pos, 0, 1, 0); \
180 insert_1_both (print_buffer, print_buffer_pos, \
181 print_buffer_pos_byte, 0, 1, 0); \
182 signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
184 if (free_print_buffer) \
186 xfree (print_buffer); \
189 unbind_to (specpdl_count, Qnil); \
190 if (MARKERP (original)) \
191 set_marker_both (original, Qnil, PT, PT_BYTE); \
192 if (old_point >= 0) \
193 SET_PT_BOTH (old_point + (old_point >= start_point \
194 ? PT - start_point : 0), \
195 old_point_byte + (old_point_byte >= start_point_byte \
196 ? PT_BYTE - start_point_byte : 0)); \
197 set_buffer_internal (old);
199 #define PRINTCHAR(ch) printchar (ch, printcharfun)
201 /* This is used to restore the saved contents of print_buffer
202 when there is a recursive call to print. */
205 print_unwind (Lisp_Object saved_text
)
207 memcpy (print_buffer
, SDATA (saved_text
), SCHARS (saved_text
));
211 /* Print character CH using method FUN. FUN nil means print to
212 print_buffer. FUN t means print to echo area or stdout if
213 non-interactive. If FUN is neither nil nor t, call FUN with CH as
217 printchar (unsigned int ch
, Lisp_Object fun
)
219 if (!NILP (fun
) && !EQ (fun
, Qt
))
220 call1 (fun
, make_number (ch
));
223 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
224 int len
= CHAR_STRING (ch
, str
);
230 ptrdiff_t incr
= len
- (print_buffer_size
- print_buffer_pos_byte
);
232 print_buffer
= xpalloc (print_buffer
, &print_buffer_size
,
234 memcpy (print_buffer
+ print_buffer_pos_byte
, str
, len
);
235 print_buffer_pos
+= 1;
236 print_buffer_pos_byte
+= len
;
238 else if (noninteractive
)
240 fwrite (str
, 1, len
, stdout
);
241 noninteractive_need_newline
= 1;
246 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
248 setup_echo_area_for_printing (multibyte_p
);
250 message_dolog ((char *) str
, len
, 0, multibyte_p
);
256 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
257 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
258 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
259 print_buffer. PRINTCHARFUN t means output to the echo area or to
260 stdout if non-interactive. If neither nil nor t, call Lisp
261 function PRINTCHARFUN for each character printed. MULTIBYTE
262 non-zero means PTR contains multibyte characters.
264 In the case where PRINTCHARFUN is nil, it is safe for PTR to point
265 to data in a Lisp string. Otherwise that is not safe. */
268 strout (const char *ptr
, ptrdiff_t size
, ptrdiff_t size_byte
,
269 Lisp_Object printcharfun
)
272 size_byte
= size
= strlen (ptr
);
274 if (NILP (printcharfun
))
276 ptrdiff_t incr
= size_byte
- (print_buffer_size
- print_buffer_pos_byte
);
278 print_buffer
= xpalloc (print_buffer
, &print_buffer_size
, incr
, -1, 1);
279 memcpy (print_buffer
+ print_buffer_pos_byte
, ptr
, size_byte
);
280 print_buffer_pos
+= size
;
281 print_buffer_pos_byte
+= size_byte
;
283 else if (noninteractive
&& EQ (printcharfun
, Qt
))
285 fwrite (ptr
, 1, size_byte
, stdout
);
286 noninteractive_need_newline
= 1;
288 else if (EQ (printcharfun
, Qt
))
290 /* Output to echo area. We're trying to avoid a little overhead
291 here, that's the reason we don't call printchar to do the
295 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
297 setup_echo_area_for_printing (multibyte_p
);
298 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
300 if (size
== size_byte
)
302 for (i
= 0; i
< size
; ++i
)
303 insert_char ((unsigned char) *ptr
++);
308 for (i
= 0; i
< size_byte
; i
+= len
)
310 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
318 /* PRINTCHARFUN is a Lisp function. */
321 if (size
== size_byte
)
323 while (i
< size_byte
)
331 while (i
< size_byte
)
333 /* Here, we must convert each multi-byte form to the
334 corresponding character code before handing it to
337 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
346 /* Print the contents of a string STRING using PRINTCHARFUN.
347 It isn't safe to use strout in many cases,
348 because printing one char can relocate. */
351 print_string (Lisp_Object string
, Lisp_Object printcharfun
)
353 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
357 if (print_escape_nonascii
)
358 string
= string_escape_byte8 (string
);
360 if (STRING_MULTIBYTE (string
))
361 chars
= SCHARS (string
);
362 else if (! print_escape_nonascii
363 && (EQ (printcharfun
, Qt
)
364 ? ! NILP (BVAR (&buffer_defaults
, enable_multibyte_characters
))
365 : ! NILP (BVAR (current_buffer
, enable_multibyte_characters
))))
367 /* If unibyte string STRING contains 8-bit codes, we must
368 convert STRING to a multibyte string containing the same
373 chars
= SBYTES (string
);
374 bytes
= count_size_as_multibyte (SDATA (string
), chars
);
377 newstr
= make_uninit_multibyte_string (chars
, bytes
);
378 memcpy (SDATA (newstr
), SDATA (string
), chars
);
379 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
384 chars
= SBYTES (string
);
386 if (EQ (printcharfun
, Qt
))
388 /* Output to echo area. */
389 ptrdiff_t nbytes
= SBYTES (string
);
391 /* Copy the string contents so that relocation of STRING by
392 GC does not cause trouble. */
394 char *buffer
= SAFE_ALLOCA (nbytes
);
395 memcpy (buffer
, SDATA (string
), nbytes
);
397 strout (buffer
, chars
, nbytes
, printcharfun
);
402 /* No need to copy, since output to print_buffer can't GC. */
403 strout (SSDATA (string
), chars
, SBYTES (string
), printcharfun
);
407 /* Otherwise, string may be relocated by printing one char.
408 So re-fetch the string address for each character. */
410 ptrdiff_t size
= SCHARS (string
);
411 ptrdiff_t size_byte
= SBYTES (string
);
414 if (size
== size_byte
)
415 for (i
= 0; i
< size
; i
++)
416 PRINTCHAR (SREF (string
, i
));
418 for (i
= 0; i
< size_byte
; )
420 /* Here, we must convert each multi-byte form to the
421 corresponding character code before handing it to PRINTCHAR. */
423 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
, len
);
431 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
432 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
433 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
434 (Lisp_Object character
, Lisp_Object printcharfun
)
438 if (NILP (printcharfun
))
439 printcharfun
= Vstandard_output
;
440 CHECK_NUMBER (character
);
442 PRINTCHAR (XINT (character
));
447 /* Used from outside of print.c to print a block of SIZE
448 single-byte chars at DATA on the default output stream.
449 Do not use this on the contents of a Lisp string. */
452 write_string (const char *data
, int size
)
455 Lisp_Object printcharfun
;
457 printcharfun
= Vstandard_output
;
460 strout (data
, size
, size
, printcharfun
);
464 /* Used to print a block of SIZE single-byte chars at DATA on a
465 specified stream PRINTCHARFUN.
466 Do not use this on the contents of a Lisp string. */
469 write_string_1 (const char *data
, int size
, Lisp_Object printcharfun
)
474 strout (data
, size
, size
, printcharfun
);
480 temp_output_buffer_setup (const char *bufname
)
482 ptrdiff_t count
= SPECPDL_INDEX ();
483 register struct buffer
*old
= current_buffer
;
484 register Lisp_Object buf
;
486 record_unwind_current_buffer ();
488 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
490 Fkill_all_local_variables ();
491 delete_all_overlays (current_buffer
);
492 bset_directory (current_buffer
, BVAR (old
, directory
));
493 bset_read_only (current_buffer
, Qnil
);
494 bset_filename (current_buffer
, Qnil
);
495 bset_undo_list (current_buffer
, Qt
);
496 eassert (current_buffer
->overlays_before
== NULL
);
497 eassert (current_buffer
->overlays_after
== NULL
);
498 bset_enable_multibyte_characters
499 (current_buffer
, BVAR (&buffer_defaults
, enable_multibyte_characters
));
500 specbind (Qinhibit_read_only
, Qt
);
501 specbind (Qinhibit_modification_hooks
, Qt
);
503 XSETBUFFER (buf
, current_buffer
);
505 Frun_hooks (1, &Qtemp_buffer_setup_hook
);
507 unbind_to (count
, Qnil
);
509 specbind (Qstandard_output
, buf
);
512 static void print (Lisp_Object
, Lisp_Object
, bool);
513 static void print_preprocess (Lisp_Object
);
514 static void print_preprocess_string (INTERVAL
, Lisp_Object
);
515 static void print_object (Lisp_Object
, Lisp_Object
, bool);
517 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
518 doc
: /* Output a newline to stream PRINTCHARFUN.
519 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
520 (Lisp_Object printcharfun
)
524 if (NILP (printcharfun
))
525 printcharfun
= Vstandard_output
;
532 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
533 doc
: /* Output the printed representation of OBJECT, any Lisp object.
534 Quoting characters are printed when needed to make output that `read'
535 can handle, whenever this is possible. For complex objects, the behavior
536 is controlled by `print-level' and `print-length', which see.
538 OBJECT is any of the Lisp data types: a number, a string, a symbol,
539 a list, a buffer, a window, a frame, etc.
541 A printed representation of an object is text which describes that object.
543 Optional argument PRINTCHARFUN is the output stream, which can be one
546 - a buffer, in which case output is inserted into that buffer at point;
547 - a marker, in which case output is inserted at marker's position;
548 - a function, in which case that function is called once for each
549 character of OBJECT's printed representation;
550 - a symbol, in which case that symbol's function definition is called; or
551 - t, in which case the output is displayed in the echo area.
553 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
555 (Lisp_Object object
, Lisp_Object printcharfun
)
559 if (NILP (printcharfun
))
560 printcharfun
= Vstandard_output
;
562 print (object
, printcharfun
, 1);
567 /* a buffer which is used to hold output being built by prin1-to-string */
568 Lisp_Object Vprin1_to_string_buffer
;
570 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
571 doc
: /* Return a string containing the printed representation of OBJECT.
572 OBJECT can be any Lisp object. This function outputs quoting characters
573 when necessary to make output that `read' can handle, whenever possible,
574 unless the optional second argument NOESCAPE is non-nil. For complex objects,
575 the behavior is controlled by `print-level' and `print-length', which see.
577 OBJECT is any of the Lisp data types: a number, a string, a symbol,
578 a list, a buffer, a window, a frame, etc.
580 A printed representation of an object is text which describes that object. */)
581 (Lisp_Object object
, Lisp_Object noescape
)
583 Lisp_Object printcharfun
;
584 bool prev_abort_on_gc
;
585 /* struct gcpro gcpro1, gcpro2; */
586 Lisp_Object save_deactivate_mark
;
587 ptrdiff_t count
= SPECPDL_INDEX ();
588 struct buffer
*previous
;
590 specbind (Qinhibit_modification_hooks
, Qt
);
595 /* Save and restore this--we are altering a buffer
596 but we don't want to deactivate the mark just for that.
597 No need for specbind, since errors deactivate the mark. */
598 save_deactivate_mark
= Vdeactivate_mark
;
599 /* GCPRO2 (object, save_deactivate_mark); */
600 prev_abort_on_gc
= abort_on_gc
;
603 printcharfun
= Vprin1_to_string_buffer
;
605 print (object
, printcharfun
, NILP (noescape
));
606 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINISH */
610 previous
= current_buffer
;
611 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
612 object
= Fbuffer_string ();
613 if (SBYTES (object
) == SCHARS (object
))
614 STRING_SET_UNIBYTE (object
);
616 /* Note that this won't make prepare_to_modify_buffer call
617 ask-user-about-supersession-threat because this buffer
618 does not visit a file. */
620 set_buffer_internal (previous
);
622 Vdeactivate_mark
= save_deactivate_mark
;
625 abort_on_gc
= prev_abort_on_gc
;
626 return unbind_to (count
, object
);
629 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
630 doc
: /* Output the printed representation of OBJECT, any Lisp object.
631 No quoting characters are used; no delimiters are printed around
632 the contents of strings.
634 OBJECT is any of the Lisp data types: a number, a string, a symbol,
635 a list, a buffer, a window, a frame, etc.
637 A printed representation of an object is text which describes that object.
639 Optional argument PRINTCHARFUN is the output stream, which can be one
642 - a buffer, in which case output is inserted into that buffer at point;
643 - a marker, in which case output is inserted at marker's position;
644 - a function, in which case that function is called once for each
645 character of OBJECT's printed representation;
646 - a symbol, in which case that symbol's function definition is called; or
647 - t, in which case the output is displayed in the echo area.
649 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
651 (Lisp_Object object
, Lisp_Object printcharfun
)
655 if (NILP (printcharfun
))
656 printcharfun
= Vstandard_output
;
658 print (object
, printcharfun
, 0);
663 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
664 doc
: /* Output the printed representation of OBJECT, with newlines around it.
665 Quoting characters are printed when needed to make output that `read'
666 can handle, whenever this is possible. For complex objects, the behavior
667 is controlled by `print-level' and `print-length', which see.
669 OBJECT is any of the Lisp data types: a number, a string, a symbol,
670 a list, a buffer, a window, a frame, etc.
672 A printed representation of an object is text which describes that object.
674 Optional argument PRINTCHARFUN is the output stream, which can be one
677 - a buffer, in which case output is inserted into that buffer at point;
678 - a marker, in which case output is inserted at marker's position;
679 - a function, in which case that function is called once for each
680 character of OBJECT's printed representation;
681 - a symbol, in which case that symbol's function definition is called; or
682 - t, in which case the output is displayed in the echo area.
684 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
686 (Lisp_Object object
, Lisp_Object printcharfun
)
691 if (NILP (printcharfun
))
692 printcharfun
= Vstandard_output
;
696 print (object
, printcharfun
, 1);
703 /* The subroutine object for external-debugging-output is kept here
704 for the convenience of the debugger. */
705 Lisp_Object Qexternal_debugging_output
;
707 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
708 doc
: /* Write CHARACTER to stderr.
709 You can call print while debugging emacs, and pass it this function
710 to make it write to the debugging output. */)
711 (Lisp_Object character
)
713 CHECK_NUMBER (character
);
714 putc (XINT (character
) & 0xFF, stderr
);
717 /* Send the output to a debugger (nothing happens if there isn't one). */
718 if (print_output_debug_flag
)
720 char buf
[2] = {(char) XINT (character
), '\0'};
721 OutputDebugString (buf
);
728 /* This function is never called. Its purpose is to prevent
729 print_output_debug_flag from being optimized away. */
731 extern void debug_output_compilation_hack (bool) EXTERNALLY_VISIBLE
;
733 debug_output_compilation_hack (bool x
)
735 print_output_debug_flag
= x
;
738 #if defined (GNU_LINUX)
740 /* This functionality is not vitally important in general, so we rely on
741 non-portable ability to use stderr as lvalue. */
743 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
745 static FILE *initial_stderr_stream
= NULL
;
747 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
749 "FDebug output file: \nP",
750 doc
: /* Redirect debugging output (stderr stream) to file FILE.
751 If FILE is nil, reset target to the initial stderr stream.
752 Optional arg APPEND non-nil (interactively, with prefix arg) means
753 append to existing target file. */)
754 (Lisp_Object file
, Lisp_Object append
)
756 if (initial_stderr_stream
!= NULL
)
762 stderr
= initial_stderr_stream
;
763 initial_stderr_stream
= NULL
;
767 file
= Fexpand_file_name (file
, Qnil
);
768 initial_stderr_stream
= stderr
;
769 stderr
= emacs_fopen (SSDATA (file
), NILP (append
) ? "w" : "a");
772 stderr
= initial_stderr_stream
;
773 initial_stderr_stream
= NULL
;
774 report_file_error ("Cannot open debugging output stream", file
);
779 #endif /* GNU_LINUX */
782 /* This is the interface for debugging printing. */
785 debug_print (Lisp_Object arg
)
787 Fprin1 (arg
, Qexternal_debugging_output
);
788 fprintf (stderr
, "\r\n");
791 void safe_debug_print (Lisp_Object
) EXTERNALLY_VISIBLE
;
793 safe_debug_print (Lisp_Object arg
)
795 int valid
= valid_lisp_object_p (arg
);
800 fprintf (stderr
, "#<%s_LISP_OBJECT 0x%08"pI
"x>\r\n",
801 !valid
? "INVALID" : "SOME",
806 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
808 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
809 See Info anchor `(elisp)Definition of signal' for some details on how this
810 error message is constructed. */)
813 struct buffer
*old
= current_buffer
;
817 /* If OBJ is (error STRING), just return STRING.
818 That is not only faster, it also avoids the need to allocate
819 space here when the error is due to memory full. */
820 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
821 && CONSP (XCDR (obj
))
822 && STRINGP (XCAR (XCDR (obj
)))
823 && NILP (XCDR (XCDR (obj
))))
824 return XCAR (XCDR (obj
));
826 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
828 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
829 value
= Fbuffer_string ();
833 set_buffer_internal (old
);
839 /* Print an error message for the error DATA onto Lisp output stream
840 STREAM (suitable for the print functions).
841 CONTEXT is a C string describing the context of the error.
842 CALLER is the Lisp function inside which the error was signaled. */
845 print_error_message (Lisp_Object data
, Lisp_Object stream
, const char *context
,
848 Lisp_Object errname
, errmsg
, file_error
, tail
;
852 write_string_1 (context
, -1, stream
);
854 /* If we know from where the error was signaled, show it in
856 if (!NILP (caller
) && SYMBOLP (caller
))
858 Lisp_Object cname
= SYMBOL_NAME (caller
);
859 ptrdiff_t cnamelen
= SBYTES (cname
);
861 char *name
= SAFE_ALLOCA (cnamelen
);
862 memcpy (name
, SDATA (cname
), cnamelen
);
863 message_dolog (name
, cnamelen
, 0, 0);
864 message_dolog (": ", 2, 0, 0);
868 errname
= Fcar (data
);
870 if (EQ (errname
, Qerror
))
875 errmsg
= Fcar (data
);
880 Lisp_Object error_conditions
= Fget (errname
, Qerror_conditions
);
881 errmsg
= Fget (errname
, Qerror_message
);
882 file_error
= Fmemq (Qfile_error
, error_conditions
);
885 /* Print an error message including the data items. */
887 tail
= Fcdr_safe (data
);
890 /* For file-error, make error message by concatenating
891 all the data items. They are all strings. */
892 if (!NILP (file_error
) && CONSP (tail
))
893 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
896 const char *sep
= ": ";
898 if (!STRINGP (errmsg
))
899 write_string_1 ("peculiar error", -1, stream
);
900 else if (SCHARS (errmsg
))
901 Fprinc (errmsg
, stream
);
905 for (; CONSP (tail
); tail
= XCDR (tail
), sep
= ", ")
910 write_string_1 (sep
, 2, stream
);
912 if (!NILP (file_error
)
913 || EQ (errname
, Qend_of_file
) || EQ (errname
, Quser_error
))
914 Fprinc (obj
, stream
);
916 Fprin1 (obj
, stream
);
926 * The buffer should be at least as large as the max string size of the
927 * largest float, printed in the biggest notation. This is undoubtedly
928 * 20d float_output_format, with the negative of the C-constant "HUGE"
931 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
933 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
934 * case of -1e307 in 20d float_output_format. What is one to do (short of
935 * re-writing _doprnt to be more sane)?
937 * Given the above, the buffer must be least FLOAT_TO_STRING_BUFSIZE bytes.
941 float_to_string (char *buf
, double data
)
947 /* Check for plus infinity in a way that won't lose
948 if there is no plus infinity. */
949 if (data
== data
/ 2 && data
> 1.0)
951 static char const infinity_string
[] = "1.0e+INF";
952 strcpy (buf
, infinity_string
);
953 return sizeof infinity_string
- 1;
955 /* Likewise for minus infinity. */
956 if (data
== data
/ 2 && data
< -1.0)
958 static char const minus_infinity_string
[] = "-1.0e+INF";
959 strcpy (buf
, minus_infinity_string
);
960 return sizeof minus_infinity_string
- 1;
962 /* Check for NaN in a way that won't fail if there are no NaNs. */
963 if (! (data
* 0.0 >= 0.0))
965 /* Prepend "-" if the NaN's sign bit is negative.
966 The sign bit of a double is the bit that is 1 in -0.0. */
967 static char const NaN_string
[] = "0.0e+NaN";
969 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
972 u_minus_zero
.d
= - 0.0;
973 for (i
= 0; i
< sizeof (double); i
++)
974 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
981 strcpy (buf
+ negative
, NaN_string
);
982 return negative
+ sizeof NaN_string
- 1;
985 if (NILP (Vfloat_output_format
)
986 || !STRINGP (Vfloat_output_format
))
989 /* Generate the fewest number of digits that represent the
990 floating point value without losing information. */
991 len
= dtoastr (buf
, FLOAT_TO_STRING_BUFSIZE
- 2, 0, 0, data
);
992 /* The decimal point must be printed, or the byte compiler can
993 get confused (Bug#8033). */
998 /* Check that the spec we have is fully valid.
999 This means not only valid for printf,
1000 but meant for floats, and reasonable. */
1001 cp
= SSDATA (Vfloat_output_format
);
1010 /* Check the width specification. */
1012 if ('0' <= *cp
&& *cp
<= '9')
1017 width
= (width
* 10) + (*cp
++ - '0');
1018 if (DBL_DIG
< width
)
1021 while (*cp
>= '0' && *cp
<= '9');
1023 /* A precision of zero is valid only for %f. */
1024 if (width
== 0 && *cp
!= 'f')
1028 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1034 len
= sprintf (buf
, SSDATA (Vfloat_output_format
), data
);
1037 /* Make sure there is a decimal point with digit after, or an
1038 exponent, so that the value is readable as a float. But don't do
1039 this with "%.0f"; it's valid for that not to produce a decimal
1040 point. Note that width can be 0 only for %.0f. */
1043 for (cp
= buf
; *cp
; cp
++)
1044 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1047 if (*cp
== '.' && cp
[1] == 0)
1067 print (Lisp_Object obj
, Lisp_Object printcharfun
, bool escapeflag
)
1069 new_backquote_output
= 0;
1071 /* Reset print_number_index and Vprint_number_table only when
1072 the variable Vprint_continuous_numbering is nil. Otherwise,
1073 the values of these variables will be kept between several
1075 if (NILP (Vprint_continuous_numbering
)
1076 || NILP (Vprint_number_table
))
1078 print_number_index
= 0;
1079 Vprint_number_table
= Qnil
;
1082 /* Construct Vprint_number_table for print-gensym and print-circle. */
1083 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1085 /* Construct Vprint_number_table.
1086 This increments print_number_index for the objects added. */
1088 print_preprocess (obj
);
1090 if (HASH_TABLE_P (Vprint_number_table
))
1091 { /* Remove unnecessary objects, which appear only once in OBJ;
1092 that is, whose status is Qt. */
1093 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vprint_number_table
);
1096 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
1097 if (!NILP (HASH_HASH (h
, i
))
1098 && EQ (HASH_VALUE (h
, i
), Qt
))
1099 Fremhash (HASH_KEY (h
, i
), Vprint_number_table
);
1104 print_object (obj
, printcharfun
, escapeflag
);
1107 #define PRINT_CIRCLE_CANDIDATE_P(obj) \
1108 (STRINGP (obj) || CONSP (obj) \
1109 || (VECTORLIKEP (obj) \
1110 && (VECTORP (obj) || COMPILEDP (obj) \
1111 || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \
1112 || HASH_TABLE_P (obj) || FONTP (obj))) \
1113 || (! NILP (Vprint_gensym) \
1115 && !SYMBOL_INTERNED_P (obj)))
1117 /* Construct Vprint_number_table according to the structure of OBJ.
1118 OBJ itself and all its elements will be added to Vprint_number_table
1119 recursively if it is a list, vector, compiled function, char-table,
1120 string (its text properties will be traced), or a symbol that has
1121 no obarray (this is for the print-gensym feature).
1122 The status fields of Vprint_number_table mean whether each object appears
1123 more than once in OBJ: Qnil at the first time, and Qt after that . */
1125 print_preprocess (Lisp_Object obj
)
1130 Lisp_Object halftail
;
1132 /* Avoid infinite recursion for circular nested structure
1133 in the case where Vprint_circle is nil. */
1134 if (NILP (Vprint_circle
))
1136 /* Give up if we go so deep that print_object will get an error. */
1137 /* See similar code in print_object. */
1138 if (print_depth
>= PRINT_CIRCLE
)
1139 error ("Apparently circular structure being printed");
1141 for (i
= 0; i
< print_depth
; i
++)
1142 if (EQ (obj
, being_printed
[i
]))
1144 being_printed
[print_depth
] = obj
;
1151 if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1153 if (!HASH_TABLE_P (Vprint_number_table
))
1155 Lisp_Object args
[2];
1158 Vprint_number_table
= Fmake_hash_table (2, args
);
1161 /* In case print-circle is nil and print-gensym is t,
1162 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1163 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1165 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1167 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1168 always print the gensym with a number. This is a special for
1169 the lisp function byte-compile-output-docform. */
1170 || (!NILP (Vprint_continuous_numbering
)
1172 && !SYMBOL_INTERNED_P (obj
)))
1173 { /* OBJ appears more than once. Let's remember that. */
1174 if (!INTEGERP (num
))
1176 print_number_index
++;
1177 /* Negative number indicates it hasn't been printed yet. */
1178 Fputhash (obj
, make_number (- print_number_index
),
1179 Vprint_number_table
);
1185 /* OBJ is not yet recorded. Let's add to the table. */
1186 Fputhash (obj
, Qt
, Vprint_number_table
);
1189 switch (XTYPE (obj
))
1192 /* A string may have text properties, which can be circular. */
1193 traverse_intervals_noorder (string_intervals (obj
),
1194 print_preprocess_string
, Qnil
);
1198 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1199 just as in print_object. */
1200 if (loop_count
&& EQ (obj
, halftail
))
1202 print_preprocess (XCAR (obj
));
1205 if (!(loop_count
& 1))
1206 halftail
= XCDR (halftail
);
1209 case Lisp_Vectorlike
:
1211 if (size
& PSEUDOVECTOR_FLAG
)
1212 size
&= PSEUDOVECTOR_SIZE_MASK
;
1213 for (i
= 0; i
< size
; i
++)
1214 print_preprocess (AREF (obj
, i
));
1215 if (HASH_TABLE_P (obj
))
1216 { /* For hash tables, the key_and_value slot is past
1217 `size' because it needs to be marked specially in case
1218 the table is weak. */
1219 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1220 print_preprocess (h
->key_and_value
);
1232 print_preprocess_string (INTERVAL interval
, Lisp_Object arg
)
1234 print_preprocess (interval
->plist
);
1237 static void print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
);
1239 #define PRINT_STRING_NON_CHARSET_FOUND 1
1240 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1242 /* Bitwise or of the above macros. */
1243 static int print_check_string_result
;
1246 print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
)
1250 if (NILP (interval
->plist
)
1251 || (print_check_string_result
== (PRINT_STRING_NON_CHARSET_FOUND
1252 | PRINT_STRING_UNSAFE_CHARSET_FOUND
)))
1254 for (val
= interval
->plist
; CONSP (val
) && ! EQ (XCAR (val
), Qcharset
);
1255 val
= XCDR (XCDR (val
)));
1258 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1261 if (! (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
))
1263 if (! EQ (val
, interval
->plist
)
1264 || CONSP (XCDR (XCDR (val
))))
1265 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1267 if (NILP (Vprint_charset_text_property
)
1268 || ! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1271 ptrdiff_t charpos
= interval
->position
;
1272 ptrdiff_t bytepos
= string_char_to_byte (string
, charpos
);
1273 Lisp_Object charset
;
1275 charset
= XCAR (XCDR (val
));
1276 for (i
= 0; i
< LENGTH (interval
); i
++)
1278 FETCH_STRING_CHAR_ADVANCE (c
, string
, charpos
, bytepos
);
1279 if (! ASCII_CHAR_P (c
)
1280 && ! EQ (CHARSET_NAME (CHAR_CHARSET (c
)), charset
))
1282 print_check_string_result
|= PRINT_STRING_UNSAFE_CHARSET_FOUND
;
1289 /* The value is (charset . nil). */
1290 static Lisp_Object print_prune_charset_plist
;
1293 print_prune_string_charset (Lisp_Object string
)
1295 print_check_string_result
= 0;
1296 traverse_intervals (string_intervals (string
), 0,
1297 print_check_string_charset_prop
, string
);
1298 if (! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1300 string
= Fcopy_sequence (string
);
1301 if (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
)
1303 if (NILP (print_prune_charset_plist
))
1304 print_prune_charset_plist
= list1 (Qcharset
);
1305 Fremove_text_properties (make_number (0),
1306 make_number (SCHARS (string
)),
1307 print_prune_charset_plist
, string
);
1310 Fset_text_properties (make_number (0), make_number (SCHARS (string
)),
1317 print_object (Lisp_Object obj
, Lisp_Object printcharfun
, bool escapeflag
)
1319 char buf
[max (sizeof "from..to..in " + 2 * INT_STRLEN_BOUND (EMACS_INT
),
1320 max (sizeof " . #" + INT_STRLEN_BOUND (printmax_t
),
1325 /* Detect circularities and truncate them. */
1326 if (NILP (Vprint_circle
))
1328 /* Simple but incomplete way. */
1331 /* See similar code in print_preprocess. */
1332 if (print_depth
>= PRINT_CIRCLE
)
1333 error ("Apparently circular structure being printed");
1335 for (i
= 0; i
< print_depth
; i
++)
1336 if (EQ (obj
, being_printed
[i
]))
1338 int len
= sprintf (buf
, "#%d", i
);
1339 strout (buf
, len
, len
, printcharfun
);
1342 being_printed
[print_depth
] = obj
;
1344 else if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1346 /* With the print-circle feature. */
1347 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1350 EMACS_INT n
= XINT (num
);
1352 { /* Add a prefix #n= if OBJ has not yet been printed;
1353 that is, its status field is nil. */
1354 int len
= sprintf (buf
, "#%"pI
"d=", -n
);
1355 strout (buf
, len
, len
, printcharfun
);
1356 /* OBJ is going to be printed. Remember that fact. */
1357 Fputhash (obj
, make_number (- n
), Vprint_number_table
);
1361 /* Just print #n# if OBJ has already been printed. */
1362 int len
= sprintf (buf
, "#%"pI
"d#", n
);
1363 strout (buf
, len
, len
, printcharfun
);
1371 switch (XTYPE (obj
))
1375 int len
= sprintf (buf
, "%"pI
"d", XINT (obj
));
1376 strout (buf
, len
, len
, printcharfun
);
1382 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
1383 int len
= float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1384 strout (pigbuf
, len
, len
, printcharfun
);
1390 print_string (obj
, printcharfun
);
1393 register ptrdiff_t i_byte
;
1394 struct gcpro gcpro1
;
1396 ptrdiff_t size_byte
;
1397 /* 1 means we must ensure that the next character we output
1398 cannot be taken as part of a hex character escape. */
1399 bool need_nonhex
= 0;
1400 bool multibyte
= STRING_MULTIBYTE (obj
);
1404 if (! EQ (Vprint_charset_text_property
, Qt
))
1405 obj
= print_prune_string_charset (obj
);
1407 if (string_intervals (obj
))
1415 size_byte
= SBYTES (obj
);
1417 for (i_byte
= 0; i_byte
< size_byte
;)
1419 /* Here, we must convert each multi-byte form to the
1420 corresponding character code before handing it to PRINTCHAR. */
1426 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
, len
);
1434 if (c
== '\n' && print_escape_newlines
)
1439 else if (c
== '\f' && print_escape_newlines
)
1445 && (CHAR_BYTE8_P (c
)
1446 || (! ASCII_CHAR_P (c
) && print_escape_multibyte
)))
1448 /* When multibyte is disabled,
1449 print multibyte string chars using hex escapes.
1450 For a char code that could be in a unibyte string,
1451 when found in a multibyte string, always use a hex escape
1452 so it reads back as multibyte. */
1456 if (CHAR_BYTE8_P (c
))
1457 len
= sprintf (outbuf
, "\\%03o", CHAR_TO_BYTE8 (c
));
1460 len
= sprintf (outbuf
, "\\x%04x", c
);
1463 strout (outbuf
, len
, len
, printcharfun
);
1465 else if (! multibyte
1466 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1467 && print_escape_nonascii
)
1469 /* When printing in a multibyte buffer
1470 or when explicitly requested,
1471 print single-byte non-ASCII string chars
1472 using octal escapes. */
1474 int len
= sprintf (outbuf
, "\\%03o", c
);
1475 strout (outbuf
, len
, len
, printcharfun
);
1479 /* If we just had a hex escape, and this character
1480 could be taken as part of it,
1481 output `\ ' to prevent that. */
1485 if ((c
>= 'a' && c
<= 'f')
1486 || (c
>= 'A' && c
<= 'F')
1487 || (c
>= '0' && c
<= '9'))
1488 strout ("\\ ", -1, -1, printcharfun
);
1491 if (c
== '\"' || c
== '\\')
1498 if (string_intervals (obj
))
1500 traverse_intervals (string_intervals (obj
),
1501 0, print_interval
, printcharfun
);
1512 unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1513 unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1515 ptrdiff_t i
, i_byte
;
1516 ptrdiff_t size_byte
;
1519 name
= SYMBOL_NAME (obj
);
1521 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1524 /* If symbol name begins with a digit, and ends with a digit,
1525 and contains nothing but digits and `e', it could be treated
1526 as a number. So set CONFUSING.
1528 Symbols that contain periods could also be taken as numbers,
1529 but periods are always escaped, so we don't have to worry
1531 else if (*p
>= '0' && *p
<= '9'
1532 && end
[-1] >= '0' && end
[-1] <= '9')
1534 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1535 /* Needed for \2e10. */
1536 || *p
== 'e' || *p
== 'E'))
1538 confusing
= (end
== p
);
1543 size_byte
= SBYTES (name
);
1545 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1550 else if (size_byte
== 0)
1557 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1559 /* Here, we must convert each multi-byte form to the
1560 corresponding character code before handing it to PRINTCHAR. */
1561 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1566 if (c
== '\"' || c
== '\\' || c
== '\''
1567 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1568 || c
== ',' || c
== '.' || c
== '`'
1569 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1571 PRINTCHAR ('\\'), confusing
= 0;
1579 /* If deeper than spec'd depth, print placeholder. */
1580 if (INTEGERP (Vprint_level
)
1581 && print_depth
> XINT (Vprint_level
))
1582 strout ("...", -1, -1, printcharfun
);
1583 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1584 && (EQ (XCAR (obj
), Qquote
)))
1587 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1589 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1590 && (EQ (XCAR (obj
), Qfunction
)))
1594 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1596 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1597 && ((EQ (XCAR (obj
), Qbackquote
))))
1599 print_object (XCAR (obj
), printcharfun
, 0);
1600 new_backquote_output
++;
1601 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1602 new_backquote_output
--;
1604 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1605 && new_backquote_output
1606 && ((EQ (XCAR (obj
), Qbackquote
)
1607 || EQ (XCAR (obj
), Qcomma
)
1608 || EQ (XCAR (obj
), Qcomma_at
)
1609 || EQ (XCAR (obj
), Qcomma_dot
))))
1611 print_object (XCAR (obj
), printcharfun
, 0);
1612 new_backquote_output
--;
1613 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1614 new_backquote_output
++;
1621 printmax_t i
, print_length
;
1622 Lisp_Object halftail
= obj
;
1624 /* Negative values of print-length are invalid in CL.
1625 Treat them like nil, as CMUCL does. */
1626 if (NATNUMP (Vprint_length
))
1627 print_length
= XFASTINT (Vprint_length
);
1629 print_length
= TYPE_MAXIMUM (printmax_t
);
1634 /* Detect circular list. */
1635 if (NILP (Vprint_circle
))
1637 /* Simple but incomplete way. */
1638 if (i
!= 0 && EQ (obj
, halftail
))
1640 int len
= sprintf (buf
, " . #%"pMd
, i
/ 2);
1641 strout (buf
, len
, len
, printcharfun
);
1647 /* With the print-circle feature. */
1650 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1653 strout (" . ", 3, 3, printcharfun
);
1654 print_object (obj
, printcharfun
, escapeflag
);
1663 if (print_length
<= i
)
1665 strout ("...", 3, 3, printcharfun
);
1670 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1674 halftail
= XCDR (halftail
);
1678 /* OBJ non-nil here means it's the end of a dotted list. */
1681 strout (" . ", 3, 3, printcharfun
);
1682 print_object (obj
, printcharfun
, escapeflag
);
1690 case Lisp_Vectorlike
:
1695 strout ("#<process ", -1, -1, printcharfun
);
1696 print_string (XPROCESS (obj
)->name
, printcharfun
);
1700 print_string (XPROCESS (obj
)->name
, printcharfun
);
1702 else if (BOOL_VECTOR_P (obj
))
1707 struct gcpro gcpro1
;
1708 ptrdiff_t size_in_chars
1709 = ((XBOOL_VECTOR (obj
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
1710 / BOOL_VECTOR_BITS_PER_CHAR
);
1716 len
= sprintf (buf
, "%"pI
"d", XBOOL_VECTOR (obj
)->size
);
1717 strout (buf
, len
, len
, printcharfun
);
1720 /* Don't print more characters than the specified maximum.
1721 Negative values of print-length are invalid. Treat them
1722 like a print-length of nil. */
1723 if (NATNUMP (Vprint_length
)
1724 && XFASTINT (Vprint_length
) < size_in_chars
)
1725 size_in_chars
= XFASTINT (Vprint_length
);
1727 for (i
= 0; i
< size_in_chars
; i
++)
1730 c
= XBOOL_VECTOR (obj
)->data
[i
];
1731 if (c
== '\n' && print_escape_newlines
)
1736 else if (c
== '\f' && print_escape_newlines
)
1741 else if (c
> '\177')
1743 /* Use octal escapes to avoid encoding issues. */
1745 PRINTCHAR ('0' + ((c
>> 6) & 3));
1746 PRINTCHAR ('0' + ((c
>> 3) & 7));
1747 PRINTCHAR ('0' + (c
& 7));
1751 if (c
== '\"' || c
== '\\')
1760 else if (SUBRP (obj
))
1762 strout ("#<subr ", -1, -1, printcharfun
);
1763 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
);
1766 #ifdef HAVE_XWIDGETS
1767 else if (XWIDGETP (obj
))
1769 strout ("#<xwidget ", -1, -1, printcharfun
);
1772 else if (XWIDGET_VIEW_P (obj
))
1774 strout ("#<xwidget-view ", -1, -1, printcharfun
);
1778 else if (WINDOWP (obj
))
1780 void *ptr
= XWINDOW (obj
);
1781 int len
= sprintf (buf
, "#<window %p", ptr
);
1782 strout (buf
, len
, len
, printcharfun
);
1783 if (BUFFERP (XWINDOW (obj
)->contents
))
1785 strout (" on ", -1, -1, printcharfun
);
1786 print_string (BVAR (XBUFFER (XWINDOW (obj
)->contents
), name
),
1791 else if (TERMINALP (obj
))
1794 struct terminal
*t
= XTERMINAL (obj
);
1795 strout ("#<terminal ", -1, -1, printcharfun
);
1796 len
= sprintf (buf
, "%d", t
->id
);
1797 strout (buf
, len
, len
, printcharfun
);
1800 strout (" on ", -1, -1, printcharfun
);
1801 strout (t
->name
, -1, -1, printcharfun
);
1805 else if (HASH_TABLE_P (obj
))
1807 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1809 ptrdiff_t real_size
, size
;
1813 strout ("#<hash-table", -1, -1, printcharfun
);
1814 if (SYMBOLP (h
->test
))
1818 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
);
1820 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
);
1822 len
= sprintf (buf
, "%"pD
"d/%"pD
"d", h
->count
, ASIZE (h
->next
));
1823 strout (buf
, len
, len
, printcharfun
);
1825 len
= sprintf (buf
, " %p>", ptr
);
1826 strout (buf
, len
, len
, printcharfun
);
1828 /* Implement a readable output, e.g.:
1829 #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
1830 /* Always print the size. */
1831 len
= sprintf (buf
, "#s(hash-table size %"pD
"d", ASIZE (h
->next
));
1832 strout (buf
, len
, len
, printcharfun
);
1834 if (!NILP (h
->test
.name
))
1836 strout (" test ", -1, -1, printcharfun
);
1837 print_object (h
->test
.name
, printcharfun
, escapeflag
);
1840 if (!NILP (h
->weak
))
1842 strout (" weakness ", -1, -1, printcharfun
);
1843 print_object (h
->weak
, printcharfun
, escapeflag
);
1846 if (!NILP (h
->rehash_size
))
1848 strout (" rehash-size ", -1, -1, printcharfun
);
1849 print_object (h
->rehash_size
, printcharfun
, escapeflag
);
1852 if (!NILP (h
->rehash_threshold
))
1854 strout (" rehash-threshold ", -1, -1, printcharfun
);
1855 print_object (h
->rehash_threshold
, printcharfun
, escapeflag
);
1858 strout (" data ", -1, -1, printcharfun
);
1860 /* Print the data here as a plist. */
1861 real_size
= HASH_TABLE_SIZE (h
);
1864 /* Don't print more elements than the specified maximum. */
1865 if (NATNUMP (Vprint_length
)
1866 && XFASTINT (Vprint_length
) < size
)
1867 size
= XFASTINT (Vprint_length
);
1870 for (i
= 0; i
< size
; i
++)
1871 if (!NILP (HASH_HASH (h
, i
)))
1873 if (i
) PRINTCHAR (' ');
1874 print_object (HASH_KEY (h
, i
), printcharfun
, escapeflag
);
1876 print_object (HASH_VALUE (h
, i
), printcharfun
, escapeflag
);
1879 if (size
< real_size
)
1880 strout (" ...", 4, 4, printcharfun
);
1886 else if (BUFFERP (obj
))
1888 if (!BUFFER_LIVE_P (XBUFFER (obj
)))
1889 strout ("#<killed buffer>", -1, -1, printcharfun
);
1890 else if (escapeflag
)
1892 strout ("#<buffer ", -1, -1, printcharfun
);
1893 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1897 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1899 else if (WINDOW_CONFIGURATIONP (obj
))
1901 strout ("#<window-configuration>", -1, -1, printcharfun
);
1903 else if (FRAMEP (obj
))
1906 void *ptr
= XFRAME (obj
);
1907 Lisp_Object frame_name
= XFRAME (obj
)->name
;
1909 strout ((FRAME_LIVE_P (XFRAME (obj
))
1910 ? "#<frame " : "#<dead frame "),
1911 -1, -1, printcharfun
);
1912 if (!STRINGP (frame_name
))
1914 /* A frame could be too young and have no name yet;
1916 if (SYMBOLP (frame_name
))
1917 frame_name
= Fsymbol_name (frame_name
);
1918 else /* can't happen: name should be either nil or string */
1919 frame_name
= build_string ("*INVALID*FRAME*NAME*");
1921 print_string (frame_name
, printcharfun
);
1922 len
= sprintf (buf
, " %p>", ptr
);
1923 strout (buf
, len
, len
, printcharfun
);
1925 else if (FONTP (obj
))
1929 if (! FONT_OBJECT_P (obj
))
1931 if (FONT_SPEC_P (obj
))
1932 strout ("#<font-spec", -1, -1, printcharfun
);
1934 strout ("#<font-entity", -1, -1, printcharfun
);
1935 for (i
= 0; i
< FONT_SPEC_MAX
; i
++)
1938 if (i
< FONT_WEIGHT_INDEX
|| i
> FONT_WIDTH_INDEX
)
1939 print_object (AREF (obj
, i
), printcharfun
, escapeflag
);
1941 print_object (font_style_symbolic (obj
, i
, 0),
1942 printcharfun
, escapeflag
);
1947 strout ("#<font-object ", -1, -1, printcharfun
);
1948 print_object (AREF (obj
, FONT_NAME_INDEX
), printcharfun
,
1955 ptrdiff_t size
= ASIZE (obj
);
1956 if (COMPILEDP (obj
))
1959 size
&= PSEUDOVECTOR_SIZE_MASK
;
1961 if (CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
))
1963 /* We print a char-table as if it were a vector,
1964 lumping the parent and default slots in with the
1965 character slots. But we add #^ as a prefix. */
1967 /* Make each lowest sub_char_table start a new line.
1968 Otherwise we'll make a line extremely long, which
1969 results in slow redisplay. */
1970 if (SUB_CHAR_TABLE_P (obj
)
1971 && XINT (XSUB_CHAR_TABLE (obj
)->depth
) == 3)
1975 if (SUB_CHAR_TABLE_P (obj
))
1977 size
&= PSEUDOVECTOR_SIZE_MASK
;
1979 if (size
& PSEUDOVECTOR_FLAG
)
1985 register Lisp_Object tem
;
1986 ptrdiff_t real_size
= size
;
1988 /* Don't print more elements than the specified maximum. */
1989 if (NATNUMP (Vprint_length
)
1990 && XFASTINT (Vprint_length
) < size
)
1991 size
= XFASTINT (Vprint_length
);
1993 for (i
= 0; i
< size
; i
++)
1995 if (i
) PRINTCHAR (' ');
1996 tem
= AREF (obj
, i
);
1997 print_object (tem
, printcharfun
, escapeflag
);
1999 if (size
< real_size
)
2000 strout (" ...", 4, 4, printcharfun
);
2007 switch (XMISCTYPE (obj
))
2009 case Lisp_Misc_Marker
:
2010 strout ("#<marker ", -1, -1, printcharfun
);
2011 /* Do you think this is necessary? */
2012 if (XMARKER (obj
)->insertion_type
!= 0)
2013 strout ("(moves after insertion) ", -1, -1, printcharfun
);
2014 if (! XMARKER (obj
)->buffer
)
2015 strout ("in no buffer", -1, -1, printcharfun
);
2018 int len
= sprintf (buf
, "at %"pD
"d", marker_position (obj
));
2019 strout (buf
, len
, len
, printcharfun
);
2020 strout (" in ", -1, -1, printcharfun
);
2021 print_string (BVAR (XMARKER (obj
)->buffer
, name
), printcharfun
);
2026 case Lisp_Misc_Overlay
:
2027 strout ("#<overlay ", -1, -1, printcharfun
);
2028 if (! XMARKER (OVERLAY_START (obj
))->buffer
)
2029 strout ("in no buffer", -1, -1, printcharfun
);
2032 int len
= sprintf (buf
, "from %"pD
"d to %"pD
"d in ",
2033 marker_position (OVERLAY_START (obj
)),
2034 marker_position (OVERLAY_END (obj
)));
2035 strout (buf
, len
, len
, printcharfun
);
2036 print_string (BVAR (XMARKER (OVERLAY_START (obj
))->buffer
, name
),
2042 /* Remaining cases shouldn't happen in normal usage, but let's
2043 print them anyway for the benefit of the debugger. */
2045 case Lisp_Misc_Free
:
2046 strout ("#<misc free cell>", -1, -1, printcharfun
);
2049 case Lisp_Misc_Save_Value
:
2052 struct Lisp_Save_Value
*v
= XSAVE_VALUE (obj
);
2054 strout ("#<save-value ", -1, -1, printcharfun
);
2056 if (v
->save_type
== SAVE_TYPE_MEMORY
)
2058 ptrdiff_t amount
= v
->data
[1].integer
;
2062 /* valid_lisp_object_p is reliable, so try to print up
2063 to 8 saved objects. This code is rarely used, so
2064 it's OK that valid_lisp_object_p is slow. */
2066 int limit
= min (amount
, 8);
2067 Lisp_Object
*area
= v
->data
[0].pointer
;
2069 i
= sprintf (buf
, "with %"pD
"d objects", amount
);
2070 strout (buf
, i
, i
, printcharfun
);
2072 for (i
= 0; i
< limit
; i
++)
2074 Lisp_Object maybe
= area
[i
];
2076 if (valid_lisp_object_p (maybe
) > 0)
2079 print_object (maybe
, printcharfun
, escapeflag
);
2082 strout (" <invalid>", -1, -1, printcharfun
);
2084 if (i
== limit
&& i
< amount
)
2085 strout (" ...", 4, 4, printcharfun
);
2087 #else /* not GC_MARK_STACK */
2089 /* There is no reliable way to determine whether the objects
2090 are initialized, so do not try to print them. */
2092 i
= sprintf (buf
, "with %"pD
"d objects", amount
);
2093 strout (buf
, i
, i
, printcharfun
);
2095 #endif /* GC_MARK_STACK */
2099 /* Print each slot according to its type. */
2101 for (index
= 0; index
< SAVE_VALUE_SLOTS
; index
++)
2106 switch (save_type (v
, index
))
2109 i
= sprintf (buf
, "<unused>");
2113 i
= sprintf (buf
, "<pointer %p>",
2114 v
->data
[index
].pointer
);
2117 case SAVE_FUNCPOINTER
:
2118 i
= sprintf (buf
, "<funcpointer %p>",
2119 ((void *) (intptr_t)
2120 v
->data
[index
].funcpointer
));
2124 i
= sprintf (buf
, "<integer %"pD
"d>",
2125 v
->data
[index
].integer
);
2129 print_object (v
->data
[index
].object
, printcharfun
,
2137 strout (buf
, i
, i
, printcharfun
);
2153 /* We're in trouble if this happens!
2154 Probably should just emacs_abort (). */
2155 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
);
2157 len
= sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2158 else if (VECTORLIKEP (obj
))
2159 len
= sprintf (buf
, "(PVEC 0x%08"pD
"x)", ASIZE (obj
));
2161 len
= sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2162 strout (buf
, len
, len
, printcharfun
);
2163 strout (" Save your buffers immediately and please report this bug>",
2164 -1, -1, printcharfun
);
2172 /* Print a description of INTERVAL using PRINTCHARFUN.
2173 This is part of printing a string that has text properties. */
2176 print_interval (INTERVAL interval
, Lisp_Object printcharfun
)
2178 if (NILP (interval
->plist
))
2181 print_object (make_number (interval
->position
), printcharfun
, 1);
2183 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2186 print_object (interval
->plist
, printcharfun
, 1);
2189 /* Initialize debug_print stuff early to have it working from the very
2193 init_print_once (void)
2195 DEFSYM (Qexternal_debugging_output
, "external-debugging-output");
2196 defsubr (&Sexternal_debugging_output
);
2200 syms_of_print (void)
2202 DEFSYM (Qtemp_buffer_setup_hook
, "temp-buffer-setup-hook");
2204 DEFVAR_LISP ("standard-output", Vstandard_output
,
2205 doc
: /* Output stream `print' uses by default for outputting a character.
2206 This may be any function of one argument.
2207 It may also be a buffer (output is inserted before point)
2208 or a marker (output is inserted and the marker is advanced)
2209 or the symbol t (output appears in the echo area). */);
2210 Vstandard_output
= Qt
;
2211 DEFSYM (Qstandard_output
, "standard-output");
2213 DEFVAR_LISP ("float-output-format", Vfloat_output_format
,
2214 doc
: /* The format descriptor string used to print floats.
2215 This is a %-spec like those accepted by `printf' in C,
2216 but with some restrictions. It must start with the two characters `%.'.
2217 After that comes an integer precision specification,
2218 and then a letter which controls the format.
2219 The letters allowed are `e', `f' and `g'.
2220 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2221 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2222 Use `g' to choose the shorter of those two formats for the number at hand.
2223 The precision in any of these cases is the number of digits following
2224 the decimal point. With `f', a precision of 0 means to omit the
2225 decimal point. 0 is not allowed with `e' or `g'.
2227 A value of nil means to use the shortest notation
2228 that represents the number without losing information. */);
2229 Vfloat_output_format
= Qnil
;
2230 DEFSYM (Qfloat_output_format
, "float-output-format");
2232 DEFVAR_LISP ("print-length", Vprint_length
,
2233 doc
: /* Maximum length of list to print before abbreviating.
2234 A value of nil means no limit. See also `eval-expression-print-length'. */);
2235 Vprint_length
= Qnil
;
2237 DEFVAR_LISP ("print-level", Vprint_level
,
2238 doc
: /* Maximum depth of list nesting to print before abbreviating.
2239 A value of nil means no limit. See also `eval-expression-print-level'. */);
2240 Vprint_level
= Qnil
;
2242 DEFVAR_BOOL ("print-escape-newlines", print_escape_newlines
,
2243 doc
: /* Non-nil means print newlines in strings as `\\n'.
2244 Also print formfeeds as `\\f'. */);
2245 print_escape_newlines
= 0;
2247 DEFVAR_BOOL ("print-escape-nonascii", print_escape_nonascii
,
2248 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2249 \(OOO is the octal representation of the character code.)
2250 Only single-byte characters are affected, and only in `prin1'.
2251 When the output goes in a multibyte buffer, this feature is
2252 enabled regardless of the value of the variable. */);
2253 print_escape_nonascii
= 0;
2255 DEFVAR_BOOL ("print-escape-multibyte", print_escape_multibyte
,
2256 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2257 \(XXXX is the hex representation of the character code.)
2258 This affects only `prin1'. */);
2259 print_escape_multibyte
= 0;
2261 DEFVAR_BOOL ("print-quoted", print_quoted
,
2262 doc
: /* Non-nil means print quoted forms with reader syntax.
2263 I.e., (quote foo) prints as 'foo, (function foo) as #'foo. */);
2266 DEFVAR_LISP ("print-gensym", Vprint_gensym
,
2267 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2268 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2269 When the uninterned symbol appears within a recursive data structure,
2270 and the symbol appears more than once, in addition use the #N# and #N=
2271 constructs as needed, so that multiple references to the same symbol are
2272 shared once again when the text is read back. */);
2273 Vprint_gensym
= Qnil
;
2275 DEFVAR_LISP ("print-circle", Vprint_circle
,
2276 doc
: /* Non-nil means print recursive structures using #N= and #N# syntax.
2277 If nil, printing proceeds recursively and may lead to
2278 `max-lisp-eval-depth' being exceeded or an error may occur:
2279 \"Apparently circular structure being printed.\" Also see
2280 `print-length' and `print-level'.
2281 If non-nil, shared substructures anywhere in the structure are printed
2282 with `#N=' before the first occurrence (in the order of the print
2283 representation) and `#N#' in place of each subsequent occurrence,
2284 where N is a positive decimal integer. */);
2285 Vprint_circle
= Qnil
;
2287 DEFVAR_LISP ("print-continuous-numbering", Vprint_continuous_numbering
,
2288 doc
: /* Non-nil means number continuously across print calls.
2289 This affects the numbers printed for #N= labels and #M# references.
2290 See also `print-circle', `print-gensym', and `print-number-table'.
2291 This variable should not be set with `setq'; bind it with a `let' instead. */);
2292 Vprint_continuous_numbering
= Qnil
;
2294 DEFVAR_LISP ("print-number-table", Vprint_number_table
,
2295 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2296 The Lisp printer uses this vector to detect Lisp objects referenced more
2299 When you bind `print-continuous-numbering' to t, you should probably
2300 also bind `print-number-table' to nil. This ensures that the value of
2301 `print-number-table' can be garbage-collected once the printing is
2302 done. If all elements of `print-number-table' are nil, it means that
2303 the printing done so far has not found any shared structure or objects
2304 that need to be recorded in the table. */);
2305 Vprint_number_table
= Qnil
;
2307 DEFVAR_LISP ("print-charset-text-property", Vprint_charset_text_property
,
2308 doc
: /* A flag to control printing of `charset' text property on printing a string.
2309 The value must be nil, t, or `default'.
2311 If the value is nil, don't print the text property `charset'.
2313 If the value is t, always print the text property `charset'.
2315 If the value is `default', print the text property `charset' only when
2316 the value is different from what is guessed in the current charset
2318 Vprint_charset_text_property
= Qdefault
;
2320 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2321 staticpro (&Vprin1_to_string_buffer
);
2324 defsubr (&Sprin1_to_string
);
2325 defsubr (&Serror_message_string
);
2329 defsubr (&Swrite_char
);
2330 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2331 defsubr (&Sredirect_debugging_output
);
2334 DEFSYM (Qprint_escape_newlines
, "print-escape-newlines");
2335 DEFSYM (Qprint_escape_multibyte
, "print-escape-multibyte");
2336 DEFSYM (Qprint_escape_nonascii
, "print-escape-nonascii");
2338 print_prune_charset_plist
= Qnil
;
2339 staticpro (&print_prune_charset_plist
);