1 /* Lisp object printing and output streams.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2011
4 Free Software Foundation, Inc.
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/>. */
27 #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
;
52 /* Default to values appropriate for IEEE floating point. */
57 /* Avoid actual stack overflow in print. */
58 static int print_depth
;
60 /* Level of nesting inside outputting backquote in new style. */
61 static int new_backquote_output
;
63 /* Detect most circularities to print finite output. */
64 #define PRINT_CIRCLE 200
65 static Lisp_Object being_printed
[PRINT_CIRCLE
];
67 /* When printing into a buffer, first we put the text in this
68 block, then insert it all at once. */
69 static char *print_buffer
;
71 /* Size allocated in print_buffer. */
72 static ptrdiff_t print_buffer_size
;
73 /* Chars stored in print_buffer. */
74 static ptrdiff_t print_buffer_pos
;
75 /* Bytes stored in print_buffer. */
76 static ptrdiff_t print_buffer_pos_byte
;
78 Lisp_Object Qprint_escape_newlines
;
79 static Lisp_Object Qprint_escape_multibyte
, Qprint_escape_nonascii
;
81 /* Vprint_number_table is a table, that keeps objects that are going to
82 be printed, to allow use of #n= and #n# to express sharing.
83 For any given object, the table can give the following values:
84 t the object will be printed only once.
85 -N the object will be printed several times and will take number N.
86 N the object has been printed so we can refer to it as #N#.
87 print_number_index holds the largest N already used.
88 N has to be striclty larger than 0 since we need to distinguish -N. */
89 static int print_number_index
;
90 static void print_interval (INTERVAL interval
, Lisp_Object printcharfun
);
92 /* GDB resets this to zero on W32 to disable OutputDebugString calls. */
93 int print_output_debug_flag EXTERNALLY_VISIBLE
= 1;
96 /* Low level output routines for characters and strings */
98 /* Lisp functions to do output using a stream
99 must have the stream in a variable called printcharfun
100 and must start with PRINTPREPARE, end with PRINTFINISH,
101 and use PRINTDECLARE to declare common variables.
102 Use PRINTCHAR to output one character,
103 or call strout to output a block of characters. */
105 #define PRINTDECLARE \
106 struct buffer *old = current_buffer; \
107 ptrdiff_t old_point = -1, start_point = -1; \
108 ptrdiff_t old_point_byte = -1, start_point_byte = -1; \
109 ptrdiff_t specpdl_count = SPECPDL_INDEX (); \
110 int free_print_buffer = 0; \
111 int multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters)); \
114 #define PRINTPREPARE \
115 original = printcharfun; \
116 if (NILP (printcharfun)) printcharfun = Qt; \
117 if (BUFFERP (printcharfun)) \
119 if (XBUFFER (printcharfun) != current_buffer) \
120 Fset_buffer (printcharfun); \
121 printcharfun = Qnil; \
123 if (MARKERP (printcharfun)) \
125 ptrdiff_t marker_pos; \
126 if (! XMARKER (printcharfun)->buffer) \
127 error ("Marker does not point anywhere"); \
128 if (XMARKER (printcharfun)->buffer != current_buffer) \
129 set_buffer_internal (XMARKER (printcharfun)->buffer); \
130 marker_pos = marker_position (printcharfun); \
131 if (marker_pos < BEGV || marker_pos > ZV) \
132 error ("Marker is outside the accessible part of the buffer"); \
134 old_point_byte = PT_BYTE; \
135 SET_PT_BOTH (marker_pos, \
136 marker_byte_position (printcharfun)); \
138 start_point_byte = PT_BYTE; \
139 printcharfun = Qnil; \
141 if (NILP (printcharfun)) \
143 Lisp_Object string; \
144 if (NILP (BVAR (current_buffer, enable_multibyte_characters)) \
145 && ! print_escape_multibyte) \
146 specbind (Qprint_escape_multibyte, Qt); \
147 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)) \
148 && ! print_escape_nonascii) \
149 specbind (Qprint_escape_nonascii, Qt); \
150 if (print_buffer != 0) \
152 string = make_string_from_bytes (print_buffer, \
154 print_buffer_pos_byte); \
155 record_unwind_protect (print_unwind, string); \
159 int new_size = 1000; \
160 print_buffer = (char *) xmalloc (new_size); \
161 print_buffer_size = new_size; \
162 free_print_buffer = 1; \
164 print_buffer_pos = 0; \
165 print_buffer_pos_byte = 0; \
167 if (EQ (printcharfun, Qt) && ! noninteractive) \
168 setup_echo_area_for_printing (multibyte);
170 #define PRINTFINISH \
171 if (NILP (printcharfun)) \
173 if (print_buffer_pos != print_buffer_pos_byte \
174 && NILP (BVAR (current_buffer, enable_multibyte_characters))) \
177 unsigned char *temp; \
178 SAFE_ALLOCA (temp, unsigned char *, print_buffer_pos + 1); \
179 copy_text ((unsigned char *) print_buffer, temp, \
180 print_buffer_pos_byte, 1, 0); \
181 insert_1_both ((char *) temp, print_buffer_pos, \
182 print_buffer_pos, 0, 1, 0); \
186 insert_1_both (print_buffer, print_buffer_pos, \
187 print_buffer_pos_byte, 0, 1, 0); \
188 signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
190 if (free_print_buffer) \
192 xfree (print_buffer); \
195 unbind_to (specpdl_count, Qnil); \
196 if (MARKERP (original)) \
197 set_marker_both (original, Qnil, PT, PT_BYTE); \
198 if (old_point >= 0) \
199 SET_PT_BOTH (old_point + (old_point >= start_point \
200 ? PT - start_point : 0), \
201 old_point_byte + (old_point_byte >= start_point_byte \
202 ? PT_BYTE - start_point_byte : 0)); \
203 if (old != current_buffer) \
204 set_buffer_internal (old);
206 #define PRINTCHAR(ch) printchar (ch, printcharfun)
208 /* This is used to restore the saved contents of print_buffer
209 when there is a recursive call to print. */
212 print_unwind (Lisp_Object saved_text
)
214 memcpy (print_buffer
, SDATA (saved_text
), SCHARS (saved_text
));
219 /* Print character CH using method FUN. FUN nil means print to
220 print_buffer. FUN t means print to echo area or stdout if
221 non-interactive. If FUN is neither nil nor t, call FUN with CH as
225 printchar (unsigned int ch
, Lisp_Object fun
)
227 if (!NILP (fun
) && !EQ (fun
, Qt
))
228 call1 (fun
, make_number (ch
));
231 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
232 int len
= CHAR_STRING (ch
, str
);
238 ptrdiff_t incr
= len
- (print_buffer_size
- print_buffer_pos_byte
);
241 xpalloc (print_buffer
, &print_buffer_size
, incr
, -1, 1);
242 memcpy (print_buffer
+ print_buffer_pos_byte
, str
, len
);
243 print_buffer_pos
+= 1;
244 print_buffer_pos_byte
+= len
;
246 else if (noninteractive
)
248 fwrite (str
, 1, len
, stdout
);
249 noninteractive_need_newline
= 1;
254 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
256 setup_echo_area_for_printing (multibyte_p
);
258 message_dolog ((char *) str
, len
, 0, multibyte_p
);
264 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
265 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
266 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
267 print_buffer. PRINTCHARFUN t means output to the echo area or to
268 stdout if non-interactive. If neither nil nor t, call Lisp
269 function PRINTCHARFUN for each character printed. MULTIBYTE
270 non-zero means PTR contains multibyte characters.
272 In the case where PRINTCHARFUN is nil, it is safe for PTR to point
273 to data in a Lisp string. Otherwise that is not safe. */
276 strout (const char *ptr
, ptrdiff_t size
, ptrdiff_t size_byte
,
277 Lisp_Object printcharfun
)
280 size_byte
= size
= strlen (ptr
);
282 if (NILP (printcharfun
))
284 ptrdiff_t incr
= size_byte
- (print_buffer_size
- print_buffer_pos_byte
);
286 print_buffer
= xpalloc (print_buffer
, &print_buffer_size
, incr
, -1, 1);
287 memcpy (print_buffer
+ print_buffer_pos_byte
, ptr
, size_byte
);
288 print_buffer_pos
+= size
;
289 print_buffer_pos_byte
+= size_byte
;
291 else if (noninteractive
&& EQ (printcharfun
, Qt
))
293 fwrite (ptr
, 1, size_byte
, stdout
);
294 noninteractive_need_newline
= 1;
296 else if (EQ (printcharfun
, Qt
))
298 /* Output to echo area. We're trying to avoid a little overhead
299 here, that's the reason we don't call printchar to do the
303 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
305 setup_echo_area_for_printing (multibyte_p
);
306 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
308 if (size
== size_byte
)
310 for (i
= 0; i
< size
; ++i
)
311 insert_char ((unsigned char) *ptr
++);
316 for (i
= 0; i
< size_byte
; i
+= len
)
318 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
326 /* PRINTCHARFUN is a Lisp function. */
329 if (size
== size_byte
)
331 while (i
< size_byte
)
339 while (i
< size_byte
)
341 /* Here, we must convert each multi-byte form to the
342 corresponding character code before handing it to
345 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
354 /* Print the contents of a string STRING using PRINTCHARFUN.
355 It isn't safe to use strout in many cases,
356 because printing one char can relocate. */
359 print_string (Lisp_Object string
, Lisp_Object printcharfun
)
361 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
365 if (print_escape_nonascii
)
366 string
= string_escape_byte8 (string
);
368 if (STRING_MULTIBYTE (string
))
369 chars
= SCHARS (string
);
370 else if (! print_escape_nonascii
371 && (EQ (printcharfun
, Qt
)
372 ? ! NILP (BVAR (&buffer_defaults
, enable_multibyte_characters
))
373 : ! NILP (BVAR (current_buffer
, enable_multibyte_characters
))))
375 /* If unibyte string STRING contains 8-bit codes, we must
376 convert STRING to a multibyte string containing the same
381 chars
= SBYTES (string
);
382 bytes
= count_size_as_multibyte (SDATA (string
), chars
);
385 newstr
= make_uninit_multibyte_string (chars
, bytes
);
386 memcpy (SDATA (newstr
), SDATA (string
), chars
);
387 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
392 chars
= SBYTES (string
);
394 if (EQ (printcharfun
, Qt
))
396 /* Output to echo area. */
397 ptrdiff_t nbytes
= SBYTES (string
);
400 /* Copy the string contents so that relocation of STRING by
401 GC does not cause trouble. */
404 SAFE_ALLOCA (buffer
, char *, nbytes
);
405 memcpy (buffer
, SDATA (string
), nbytes
);
407 strout (buffer
, chars
, SBYTES (string
), printcharfun
);
412 /* No need to copy, since output to print_buffer can't GC. */
413 strout (SSDATA (string
), chars
, SBYTES (string
), printcharfun
);
417 /* Otherwise, string may be relocated by printing one char.
418 So re-fetch the string address for each character. */
420 ptrdiff_t size
= SCHARS (string
);
421 ptrdiff_t size_byte
= SBYTES (string
);
424 if (size
== size_byte
)
425 for (i
= 0; i
< size
; i
++)
426 PRINTCHAR (SREF (string
, i
));
428 for (i
= 0; i
< size_byte
; )
430 /* Here, we must convert each multi-byte form to the
431 corresponding character code before handing it to PRINTCHAR. */
433 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
, len
);
441 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
442 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
443 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
444 (Lisp_Object character
, Lisp_Object printcharfun
)
448 if (NILP (printcharfun
))
449 printcharfun
= Vstandard_output
;
450 CHECK_NUMBER (character
);
452 PRINTCHAR (XINT (character
));
457 /* Used from outside of print.c to print a block of SIZE
458 single-byte chars at DATA on the default output stream.
459 Do not use this on the contents of a Lisp string. */
462 write_string (const char *data
, int size
)
465 Lisp_Object printcharfun
;
467 printcharfun
= Vstandard_output
;
470 strout (data
, size
, size
, printcharfun
);
474 /* Used to print a block of SIZE single-byte chars at DATA on a
475 specified stream PRINTCHARFUN.
476 Do not use this on the contents of a Lisp string. */
479 write_string_1 (const char *data
, int size
, Lisp_Object printcharfun
)
484 strout (data
, size
, size
, printcharfun
);
490 temp_output_buffer_setup (const char *bufname
)
492 ptrdiff_t count
= SPECPDL_INDEX ();
493 register struct buffer
*old
= current_buffer
;
494 register Lisp_Object buf
;
496 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
498 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
500 Fkill_all_local_variables ();
501 delete_all_overlays (current_buffer
);
502 BVAR (current_buffer
, directory
) = BVAR (old
, directory
);
503 BVAR (current_buffer
, read_only
) = Qnil
;
504 BVAR (current_buffer
, filename
) = Qnil
;
505 BVAR (current_buffer
, undo_list
) = Qt
;
506 eassert (current_buffer
->overlays_before
== NULL
);
507 eassert (current_buffer
->overlays_after
== NULL
);
508 BVAR (current_buffer
, enable_multibyte_characters
)
509 = BVAR (&buffer_defaults
, enable_multibyte_characters
);
510 specbind (Qinhibit_read_only
, Qt
);
511 specbind (Qinhibit_modification_hooks
, Qt
);
513 XSETBUFFER (buf
, current_buffer
);
515 Frun_hooks (1, &Qtemp_buffer_setup_hook
);
517 unbind_to (count
, Qnil
);
519 specbind (Qstandard_output
, buf
);
522 static void print (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
);
523 static void print_preprocess (Lisp_Object obj
);
524 static void print_preprocess_string (INTERVAL interval
, Lisp_Object arg
);
525 static void print_object (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
);
527 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
528 doc
: /* Output a newline to stream PRINTCHARFUN.
529 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
530 (Lisp_Object printcharfun
)
534 if (NILP (printcharfun
))
535 printcharfun
= Vstandard_output
;
542 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
543 doc
: /* Output the printed representation of OBJECT, any Lisp object.
544 Quoting characters are printed when needed to make output that `read'
545 can handle, whenever this is possible. For complex objects, the behavior
546 is controlled by `print-level' and `print-length', which see.
548 OBJECT is any of the Lisp data types: a number, a string, a symbol,
549 a list, a buffer, a window, a frame, etc.
551 A printed representation of an object is text which describes that object.
553 Optional argument PRINTCHARFUN is the output stream, which can be one
556 - a buffer, in which case output is inserted into that buffer at point;
557 - a marker, in which case output is inserted at marker's position;
558 - a function, in which case that function is called once for each
559 character of OBJECT's printed representation;
560 - a symbol, in which case that symbol's function definition is called; or
561 - t, in which case the output is displayed in the echo area.
563 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
565 (Lisp_Object object
, Lisp_Object printcharfun
)
569 if (NILP (printcharfun
))
570 printcharfun
= Vstandard_output
;
572 print (object
, printcharfun
, 1);
577 /* a buffer which is used to hold output being built by prin1-to-string */
578 Lisp_Object Vprin1_to_string_buffer
;
580 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
581 doc
: /* Return a string containing the printed representation of OBJECT.
582 OBJECT can be any Lisp object. This function outputs quoting characters
583 when necessary to make output that `read' can handle, whenever possible,
584 unless the optional second argument NOESCAPE is non-nil. For complex objects,
585 the behavior is controlled by `print-level' and `print-length', which see.
587 OBJECT is any of the Lisp data types: a number, a string, a symbol,
588 a list, a buffer, a window, a frame, etc.
590 A printed representation of an object is text which describes that object. */)
591 (Lisp_Object object
, Lisp_Object noescape
)
593 Lisp_Object printcharfun
;
594 /* struct gcpro gcpro1, gcpro2; */
595 Lisp_Object save_deactivate_mark
;
596 ptrdiff_t count
= SPECPDL_INDEX ();
597 struct buffer
*previous
;
599 specbind (Qinhibit_modification_hooks
, Qt
);
604 /* Save and restore this--we are altering a buffer
605 but we don't want to deactivate the mark just for that.
606 No need for specbind, since errors deactivate the mark. */
607 save_deactivate_mark
= Vdeactivate_mark
;
608 /* GCPRO2 (object, save_deactivate_mark); */
611 printcharfun
= Vprin1_to_string_buffer
;
613 print (object
, printcharfun
, NILP (noescape
));
614 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
618 previous
= current_buffer
;
619 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
620 object
= Fbuffer_string ();
621 if (SBYTES (object
) == SCHARS (object
))
622 STRING_SET_UNIBYTE (object
);
624 /* Note that this won't make prepare_to_modify_buffer call
625 ask-user-about-supersession-threat because this buffer
626 does not visit a file. */
628 set_buffer_internal (previous
);
630 Vdeactivate_mark
= save_deactivate_mark
;
634 return unbind_to (count
, object
);
637 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
638 doc
: /* Output the printed representation of OBJECT, any Lisp object.
639 No quoting characters are used; no delimiters are printed around
640 the contents of strings.
642 OBJECT is any of the Lisp data types: a number, a string, a symbol,
643 a list, a buffer, a window, a frame, etc.
645 A printed representation of an object is text which describes that object.
647 Optional argument PRINTCHARFUN is the output stream, which can be one
650 - a buffer, in which case output is inserted into that buffer at point;
651 - a marker, in which case output is inserted at marker's position;
652 - a function, in which case that function is called once for each
653 character of OBJECT's printed representation;
654 - a symbol, in which case that symbol's function definition is called; or
655 - t, in which case the output is displayed in the echo area.
657 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
659 (Lisp_Object object
, Lisp_Object printcharfun
)
663 if (NILP (printcharfun
))
664 printcharfun
= Vstandard_output
;
666 print (object
, printcharfun
, 0);
671 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
672 doc
: /* Output the printed representation of OBJECT, with newlines around it.
673 Quoting characters are printed when needed to make output that `read'
674 can handle, whenever this is possible. For complex objects, the behavior
675 is controlled by `print-level' and `print-length', which see.
677 OBJECT is any of the Lisp data types: a number, a string, a symbol,
678 a list, a buffer, a window, a frame, etc.
680 A printed representation of an object is text which describes that object.
682 Optional argument PRINTCHARFUN is the output stream, which can be one
685 - a buffer, in which case output is inserted into that buffer at point;
686 - a marker, in which case output is inserted at marker's position;
687 - a function, in which case that function is called once for each
688 character of OBJECT's printed representation;
689 - a symbol, in which case that symbol's function definition is called; or
690 - t, in which case the output is displayed in the echo area.
692 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
694 (Lisp_Object object
, Lisp_Object printcharfun
)
699 if (NILP (printcharfun
))
700 printcharfun
= Vstandard_output
;
704 print (object
, printcharfun
, 1);
711 /* The subroutine object for external-debugging-output is kept here
712 for the convenience of the debugger. */
713 Lisp_Object Qexternal_debugging_output
;
715 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
716 doc
: /* Write CHARACTER to stderr.
717 You can call print while debugging emacs, and pass it this function
718 to make it write to the debugging output. */)
719 (Lisp_Object character
)
721 CHECK_CHARACTER (character
);
722 putc ((int) XINT (character
), stderr
);
725 /* Send the output to a debugger (nothing happens if there isn't one). */
726 if (print_output_debug_flag
)
728 char buf
[2] = {(char) XINT (character
), '\0'};
729 OutputDebugString (buf
);
736 /* This function is never called. Its purpose is to prevent
737 print_output_debug_flag from being optimized away. */
739 extern void debug_output_compilation_hack (int) EXTERNALLY_VISIBLE
;
741 debug_output_compilation_hack (int x
)
743 print_output_debug_flag
= x
;
746 #if defined (GNU_LINUX)
748 /* This functionality is not vitally important in general, so we rely on
749 non-portable ability to use stderr as lvalue. */
751 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
753 static FILE *initial_stderr_stream
= NULL
;
755 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
757 "FDebug output file: \nP",
758 doc
: /* Redirect debugging output (stderr stream) to file FILE.
759 If FILE is nil, reset target to the initial stderr stream.
760 Optional arg APPEND non-nil (interactively, with prefix arg) means
761 append to existing target file. */)
762 (Lisp_Object file
, Lisp_Object append
)
764 if (initial_stderr_stream
!= NULL
)
770 stderr
= initial_stderr_stream
;
771 initial_stderr_stream
= NULL
;
775 file
= Fexpand_file_name (file
, Qnil
);
776 initial_stderr_stream
= stderr
;
777 stderr
= fopen (SSDATA (file
), NILP (append
) ? "w" : "a");
780 stderr
= initial_stderr_stream
;
781 initial_stderr_stream
= NULL
;
782 report_file_error ("Cannot open debugging output stream",
788 #endif /* GNU_LINUX */
791 /* This is the interface for debugging printing. */
794 debug_print (Lisp_Object arg
)
796 Fprin1 (arg
, Qexternal_debugging_output
);
797 fprintf (stderr
, "\r\n");
800 void safe_debug_print (Lisp_Object
) EXTERNALLY_VISIBLE
;
802 safe_debug_print (Lisp_Object arg
)
804 int valid
= valid_lisp_object_p (arg
);
809 fprintf (stderr
, "#<%s_LISP_OBJECT 0x%08"pI
"x>\r\n",
810 !valid
? "INVALID" : "SOME",
815 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
817 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
818 See Info anchor `(elisp)Definition of signal' for some details on how this
819 error message is constructed. */)
822 struct buffer
*old
= current_buffer
;
826 /* If OBJ is (error STRING), just return STRING.
827 That is not only faster, it also avoids the need to allocate
828 space here when the error is due to memory full. */
829 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
830 && CONSP (XCDR (obj
))
831 && STRINGP (XCAR (XCDR (obj
)))
832 && NILP (XCDR (XCDR (obj
))))
833 return XCAR (XCDR (obj
));
835 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
837 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
838 value
= Fbuffer_string ();
842 set_buffer_internal (old
);
848 /* Print an error message for the error DATA onto Lisp output stream
849 STREAM (suitable for the print functions).
850 CONTEXT is a C string describing the context of the error.
851 CALLER is the Lisp function inside which the error was signaled. */
854 print_error_message (Lisp_Object data
, Lisp_Object stream
, const char *context
,
857 Lisp_Object errname
, errmsg
, file_error
, tail
;
862 write_string_1 (context
, -1, stream
);
864 /* If we know from where the error was signaled, show it in
866 if (!NILP (caller
) && SYMBOLP (caller
))
868 Lisp_Object cname
= SYMBOL_NAME (caller
);
871 SAFE_ALLOCA (name
, char *, SBYTES (cname
));
872 memcpy (name
, SDATA (cname
), SBYTES (cname
));
873 message_dolog (name
, SBYTES (cname
), 0, 0);
874 message_dolog (": ", 2, 0, 0);
878 errname
= Fcar (data
);
880 if (EQ (errname
, Qerror
))
885 errmsg
= Fcar (data
);
890 Lisp_Object error_conditions
;
891 errmsg
= Fget (errname
, Qerror_message
);
892 error_conditions
= Fget (errname
, Qerror_conditions
);
893 file_error
= Fmemq (Qfile_error
, error_conditions
);
896 /* Print an error message including the data items. */
898 tail
= Fcdr_safe (data
);
901 /* For file-error, make error message by concatenating
902 all the data items. They are all strings. */
903 if (!NILP (file_error
) && CONSP (tail
))
904 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
906 if (STRINGP (errmsg
))
907 Fprinc (errmsg
, stream
);
909 write_string_1 ("peculiar error", -1, stream
);
911 for (i
= 0; CONSP (tail
); tail
= XCDR (tail
), i
= 1)
915 write_string_1 (i
? ", " : ": ", 2, stream
);
917 if (!NILP (file_error
) || EQ (errname
, Qend_of_file
))
918 Fprinc (obj
, stream
);
920 Fprin1 (obj
, stream
);
929 * The buffer should be at least as large as the max string size of the
930 * largest float, printed in the biggest notation. This is undoubtedly
931 * 20d float_output_format, with the negative of the C-constant "HUGE"
934 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
936 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
937 * case of -1e307 in 20d float_output_format. What is one to do (short of
938 * re-writing _doprnt to be more sane)?
940 * Given the above, the buffer must be least FLOAT_TO_STRING_BUFSIZE bytes.
944 float_to_string (char *buf
, double data
)
949 /* Check for plus infinity in a way that won't lose
950 if there is no plus infinity. */
951 if (data
== data
/ 2 && data
> 1.0)
953 strcpy (buf
, "1.0e+INF");
956 /* Likewise for minus infinity. */
957 if (data
== data
/ 2 && data
< -1.0)
959 strcpy (buf
, "-1.0e+INF");
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. */
968 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
970 u_minus_zero
.d
= - 0.0;
971 for (i
= 0; i
< sizeof (double); i
++)
972 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
978 strcpy (buf
, "0.0e+NaN");
982 if (NILP (Vfloat_output_format
)
983 || !STRINGP (Vfloat_output_format
))
986 /* Generate the fewest number of digits that represent the
987 floating point value without losing information. */
988 dtoastr (buf
, FLOAT_TO_STRING_BUFSIZE
- 2, 0, 0, data
);
989 /* The decimal point must be printed, or the byte compiler can
990 get confused (Bug#8033). */
995 /* Check that the spec we have is fully valid.
996 This means not only valid for printf,
997 but meant for floats, and reasonable. */
998 cp
= SSDATA (Vfloat_output_format
);
1007 /* Check the width specification. */
1009 if ('0' <= *cp
&& *cp
<= '9')
1014 width
= (width
* 10) + (*cp
++ - '0');
1015 if (DBL_DIG
< width
)
1018 while (*cp
>= '0' && *cp
<= '9');
1020 /* A precision of zero is valid only for %f. */
1021 if (width
== 0 && *cp
!= 'f')
1025 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1031 sprintf (buf
, SSDATA (Vfloat_output_format
), data
);
1034 /* Make sure there is a decimal point with digit after, or an
1035 exponent, so that the value is readable as a float. But don't do
1036 this with "%.0f"; it's valid for that not to produce a decimal
1037 point. Note that width can be 0 only for %.0f. */
1040 for (cp
= buf
; *cp
; cp
++)
1041 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1044 if (*cp
== '.' && cp
[1] == 0)
1060 print (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
)
1062 new_backquote_output
= 0;
1064 /* Reset print_number_index and Vprint_number_table only when
1065 the variable Vprint_continuous_numbering is nil. Otherwise,
1066 the values of these variables will be kept between several
1068 if (NILP (Vprint_continuous_numbering
)
1069 || NILP (Vprint_number_table
))
1071 print_number_index
= 0;
1072 Vprint_number_table
= Qnil
;
1075 /* Construct Vprint_number_table for print-gensym and print-circle. */
1076 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1078 /* Construct Vprint_number_table.
1079 This increments print_number_index for the objects added. */
1081 print_preprocess (obj
);
1083 if (HASH_TABLE_P (Vprint_number_table
))
1084 { /* Remove unnecessary objects, which appear only once in OBJ;
1085 that is, whose status is Qt.
1086 Maybe a better way to do that is to copy elements to
1087 a new hash table. */
1088 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vprint_number_table
);
1091 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
1092 if (!NILP (HASH_HASH (h
, i
))
1093 && EQ (HASH_VALUE (h
, i
), Qt
))
1094 Fremhash (HASH_KEY (h
, i
), Vprint_number_table
);
1099 print_object (obj
, printcharfun
, escapeflag
);
1102 #define PRINT_CIRCLE_CANDIDATE_P(obj) \
1103 (STRINGP (obj) || CONSP (obj) \
1104 || (VECTORLIKEP (obj) \
1105 && (VECTORP (obj) || COMPILEDP (obj) \
1106 || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \
1107 || HASH_TABLE_P (obj) || FONTP (obj))) \
1108 || (! NILP (Vprint_gensym) \
1110 && !SYMBOL_INTERNED_P (obj)))
1112 /* Construct Vprint_number_table according to the structure of OBJ.
1113 OBJ itself and all its elements will be added to Vprint_number_table
1114 recursively if it is a list, vector, compiled function, char-table,
1115 string (its text properties will be traced), or a symbol that has
1116 no obarray (this is for the print-gensym feature).
1117 The status fields of Vprint_number_table mean whether each object appears
1118 more than once in OBJ: Qnil at the first time, and Qt after that . */
1120 print_preprocess (Lisp_Object obj
)
1125 Lisp_Object halftail
;
1127 /* Give up if we go so deep that print_object will get an error. */
1128 /* See similar code in print_object. */
1129 if (print_depth
>= PRINT_CIRCLE
)
1130 error ("Apparently circular structure being printed");
1132 /* Avoid infinite recursion for circular nested structure
1133 in the case where Vprint_circle is nil. */
1134 if (NILP (Vprint_circle
))
1136 for (i
= 0; i
< print_depth
; i
++)
1137 if (EQ (obj
, being_printed
[i
]))
1139 being_printed
[print_depth
] = obj
;
1146 if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1148 if (!HASH_TABLE_P (Vprint_number_table
))
1150 Lisp_Object args
[2];
1153 Vprint_number_table
= Fmake_hash_table (2, args
);
1156 /* In case print-circle is nil and print-gensym is t,
1157 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1158 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1160 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1162 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1163 always print the gensym with a number. This is a special for
1164 the lisp function byte-compile-output-docform. */
1165 || (!NILP (Vprint_continuous_numbering
)
1167 && !SYMBOL_INTERNED_P (obj
)))
1168 { /* OBJ appears more than once. Let's remember that. */
1169 if (!INTEGERP (num
))
1171 print_number_index
++;
1172 /* Negative number indicates it hasn't been printed yet. */
1173 Fputhash (obj
, make_number (- print_number_index
),
1174 Vprint_number_table
);
1180 /* OBJ is not yet recorded. Let's add to the table. */
1181 Fputhash (obj
, Qt
, Vprint_number_table
);
1184 switch (XTYPE (obj
))
1187 /* A string may have text properties, which can be circular. */
1188 traverse_intervals_noorder (STRING_INTERVALS (obj
),
1189 print_preprocess_string
, Qnil
);
1193 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1194 just as in print_object. */
1195 if (loop_count
&& EQ (obj
, halftail
))
1197 print_preprocess (XCAR (obj
));
1200 if (!(loop_count
& 1))
1201 halftail
= XCDR (halftail
);
1204 case Lisp_Vectorlike
:
1206 if (size
& PSEUDOVECTOR_FLAG
)
1207 size
&= PSEUDOVECTOR_SIZE_MASK
;
1208 for (i
= 0; i
< size
; i
++)
1209 print_preprocess (XVECTOR (obj
)->contents
[i
]);
1210 if (HASH_TABLE_P (obj
))
1211 { /* For hash tables, the key_and_value slot is past
1212 `size' because it needs to be marked specially in case
1213 the table is weak. */
1214 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1215 print_preprocess (h
->key_and_value
);
1227 print_preprocess_string (INTERVAL interval
, Lisp_Object arg
)
1229 print_preprocess (interval
->plist
);
1232 static void print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
);
1234 #define PRINT_STRING_NON_CHARSET_FOUND 1
1235 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1237 /* Bitwise or of the above macros. */
1238 static int print_check_string_result
;
1241 print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
)
1245 if (NILP (interval
->plist
)
1246 || (print_check_string_result
== (PRINT_STRING_NON_CHARSET_FOUND
1247 | PRINT_STRING_UNSAFE_CHARSET_FOUND
)))
1249 for (val
= interval
->plist
; CONSP (val
) && ! EQ (XCAR (val
), Qcharset
);
1250 val
= XCDR (XCDR (val
)));
1253 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1256 if (! (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
))
1258 if (! EQ (val
, interval
->plist
)
1259 || CONSP (XCDR (XCDR (val
))))
1260 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1262 if (NILP (Vprint_charset_text_property
)
1263 || ! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1266 ptrdiff_t charpos
= interval
->position
;
1267 ptrdiff_t bytepos
= string_char_to_byte (string
, charpos
);
1268 Lisp_Object charset
;
1270 charset
= XCAR (XCDR (val
));
1271 for (i
= 0; i
< LENGTH (interval
); i
++)
1273 FETCH_STRING_CHAR_ADVANCE (c
, string
, charpos
, bytepos
);
1274 if (! ASCII_CHAR_P (c
)
1275 && ! EQ (CHARSET_NAME (CHAR_CHARSET (c
)), charset
))
1277 print_check_string_result
|= PRINT_STRING_UNSAFE_CHARSET_FOUND
;
1284 /* The value is (charset . nil). */
1285 static Lisp_Object print_prune_charset_plist
;
1288 print_prune_string_charset (Lisp_Object string
)
1290 print_check_string_result
= 0;
1291 traverse_intervals (STRING_INTERVALS (string
), 0,
1292 print_check_string_charset_prop
, string
);
1293 if (! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1295 string
= Fcopy_sequence (string
);
1296 if (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
)
1298 if (NILP (print_prune_charset_plist
))
1299 print_prune_charset_plist
= Fcons (Qcharset
, Qnil
);
1300 Fremove_text_properties (make_number (0),
1301 make_number (SCHARS (string
)),
1302 print_prune_charset_plist
, string
);
1305 Fset_text_properties (make_number (0), make_number (SCHARS (string
)),
1312 print_object (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
)
1314 char buf
[max (sizeof "from..to..in " + 2 * INT_STRLEN_BOUND (EMACS_INT
),
1315 max (sizeof " . #" + INT_STRLEN_BOUND (printmax_t
),
1320 /* See similar code in print_preprocess. */
1321 if (print_depth
>= PRINT_CIRCLE
)
1322 error ("Apparently circular structure being printed");
1324 /* Detect circularities and truncate them. */
1325 if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1327 if (NILP (Vprint_circle
) && NILP (Vprint_gensym
))
1329 /* Simple but incomplete way. */
1331 for (i
= 0; i
< print_depth
; i
++)
1332 if (EQ (obj
, being_printed
[i
]))
1334 sprintf (buf
, "#%d", i
);
1335 strout (buf
, -1, -1, printcharfun
);
1338 being_printed
[print_depth
] = obj
;
1342 /* With the print-circle feature. */
1343 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1346 EMACS_INT n
= XINT (num
);
1348 { /* Add a prefix #n= if OBJ has not yet been printed;
1349 that is, its status field is nil. */
1350 sprintf (buf
, "#%"pI
"d=", -n
);
1351 strout (buf
, -1, -1, printcharfun
);
1352 /* OBJ is going to be printed. Remember that fact. */
1353 Fputhash (obj
, make_number (- n
), Vprint_number_table
);
1357 /* Just print #n# if OBJ has already been printed. */
1358 sprintf (buf
, "#%"pI
"d#", n
);
1359 strout (buf
, -1, -1, printcharfun
);
1368 switch (XTYPE (obj
))
1371 sprintf (buf
, "%"pI
"d", XINT (obj
));
1372 strout (buf
, -1, -1, printcharfun
);
1377 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
1379 float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1380 strout (pigbuf
, -1, -1, printcharfun
);
1386 print_string (obj
, printcharfun
);
1389 register ptrdiff_t i_byte
;
1390 struct gcpro gcpro1
;
1392 ptrdiff_t size_byte
;
1393 /* 1 means we must ensure that the next character we output
1394 cannot be taken as part of a hex character escape. */
1395 int need_nonhex
= 0;
1396 int multibyte
= STRING_MULTIBYTE (obj
);
1400 if (! EQ (Vprint_charset_text_property
, Qt
))
1401 obj
= print_prune_string_charset (obj
);
1403 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1411 size_byte
= SBYTES (obj
);
1413 for (i_byte
= 0; i_byte
< size_byte
;)
1415 /* Here, we must convert each multi-byte form to the
1416 corresponding character code before handing it to PRINTCHAR. */
1422 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
, len
);
1430 if (c
== '\n' && print_escape_newlines
)
1435 else if (c
== '\f' && print_escape_newlines
)
1441 && (CHAR_BYTE8_P (c
)
1442 || (! ASCII_CHAR_P (c
) && print_escape_multibyte
)))
1444 /* When multibyte is disabled,
1445 print multibyte string chars using hex escapes.
1446 For a char code that could be in a unibyte string,
1447 when found in a multibyte string, always use a hex escape
1448 so it reads back as multibyte. */
1451 if (CHAR_BYTE8_P (c
))
1452 sprintf (outbuf
, "\\%03o", CHAR_TO_BYTE8 (c
));
1455 sprintf (outbuf
, "\\x%04x", c
);
1458 strout (outbuf
, -1, -1, printcharfun
);
1460 else if (! multibyte
1461 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1462 && print_escape_nonascii
)
1464 /* When printing in a multibyte buffer
1465 or when explicitly requested,
1466 print single-byte non-ASCII string chars
1467 using octal escapes. */
1469 sprintf (outbuf
, "\\%03o", c
);
1470 strout (outbuf
, -1, -1, printcharfun
);
1474 /* If we just had a hex escape, and this character
1475 could be taken as part of it,
1476 output `\ ' to prevent that. */
1480 if ((c
>= 'a' && c
<= 'f')
1481 || (c
>= 'A' && c
<= 'F')
1482 || (c
>= '0' && c
<= '9'))
1483 strout ("\\ ", -1, -1, printcharfun
);
1486 if (c
== '\"' || c
== '\\')
1493 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1495 traverse_intervals (STRING_INTERVALS (obj
),
1496 0, print_interval
, printcharfun
);
1506 register int confusing
;
1507 register unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1508 register unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1510 ptrdiff_t i
, i_byte
;
1511 ptrdiff_t size_byte
;
1514 name
= SYMBOL_NAME (obj
);
1516 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1519 /* If symbol name begins with a digit, and ends with a digit,
1520 and contains nothing but digits and `e', it could be treated
1521 as a number. So set CONFUSING.
1523 Symbols that contain periods could also be taken as numbers,
1524 but periods are always escaped, so we don't have to worry
1526 else if (*p
>= '0' && *p
<= '9'
1527 && end
[-1] >= '0' && end
[-1] <= '9')
1529 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1530 /* Needed for \2e10. */
1531 || *p
== 'e' || *p
== 'E'))
1533 confusing
= (end
== p
);
1538 size_byte
= SBYTES (name
);
1540 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1545 else if (size_byte
== 0)
1552 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1554 /* Here, we must convert each multi-byte form to the
1555 corresponding character code before handing it to PRINTCHAR. */
1556 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1561 if (c
== '\"' || c
== '\\' || c
== '\''
1562 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1563 || c
== ',' || c
== '.' || c
== '`'
1564 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1566 PRINTCHAR ('\\'), confusing
= 0;
1574 /* If deeper than spec'd depth, print placeholder. */
1575 if (INTEGERP (Vprint_level
)
1576 && print_depth
> XINT (Vprint_level
))
1577 strout ("...", -1, -1, printcharfun
);
1578 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1579 && (EQ (XCAR (obj
), Qquote
)))
1582 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1584 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1585 && (EQ (XCAR (obj
), Qfunction
)))
1589 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1591 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1592 && ((EQ (XCAR (obj
), Qbackquote
))))
1594 print_object (XCAR (obj
), printcharfun
, 0);
1595 new_backquote_output
++;
1596 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1597 new_backquote_output
--;
1599 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1600 && new_backquote_output
1601 && ((EQ (XCAR (obj
), Qbackquote
)
1602 || EQ (XCAR (obj
), Qcomma
)
1603 || EQ (XCAR (obj
), Qcomma_at
)
1604 || EQ (XCAR (obj
), Qcomma_dot
))))
1606 print_object (XCAR (obj
), printcharfun
, 0);
1607 new_backquote_output
--;
1608 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1609 new_backquote_output
++;
1616 printmax_t i
, print_length
;
1617 Lisp_Object halftail
= obj
;
1619 /* Negative values of print-length are invalid in CL.
1620 Treat them like nil, as CMUCL does. */
1621 if (NATNUMP (Vprint_length
))
1622 print_length
= XFASTINT (Vprint_length
);
1624 print_length
= TYPE_MAXIMUM (printmax_t
);
1629 /* Detect circular list. */
1630 if (NILP (Vprint_circle
))
1632 /* Simple but imcomplete way. */
1633 if (i
!= 0 && EQ (obj
, halftail
))
1635 sprintf (buf
, " . #%"pMd
, i
/ 2);
1636 strout (buf
, -1, -1, printcharfun
);
1642 /* With the print-circle feature. */
1645 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1648 strout (" . ", 3, 3, printcharfun
);
1649 print_object (obj
, printcharfun
, escapeflag
);
1658 if (print_length
<= i
)
1660 strout ("...", 3, 3, printcharfun
);
1665 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1669 halftail
= XCDR (halftail
);
1673 /* OBJ non-nil here means it's the end of a dotted list. */
1676 strout (" . ", 3, 3, printcharfun
);
1677 print_object (obj
, printcharfun
, escapeflag
);
1685 case Lisp_Vectorlike
:
1690 strout ("#<process ", -1, -1, printcharfun
);
1691 print_string (XPROCESS (obj
)->name
, printcharfun
);
1695 print_string (XPROCESS (obj
)->name
, printcharfun
);
1697 else if (BOOL_VECTOR_P (obj
))
1700 register unsigned char c
;
1701 struct gcpro gcpro1
;
1702 ptrdiff_t size_in_chars
1703 = ((XBOOL_VECTOR (obj
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
1704 / BOOL_VECTOR_BITS_PER_CHAR
);
1710 sprintf (buf
, "%"pI
"d", XBOOL_VECTOR (obj
)->size
);
1711 strout (buf
, -1, -1, printcharfun
);
1714 /* Don't print more characters than the specified maximum.
1715 Negative values of print-length are invalid. Treat them
1716 like a print-length of nil. */
1717 if (NATNUMP (Vprint_length
)
1718 && XFASTINT (Vprint_length
) < size_in_chars
)
1719 size_in_chars
= XFASTINT (Vprint_length
);
1721 for (i
= 0; i
< size_in_chars
; i
++)
1724 c
= XBOOL_VECTOR (obj
)->data
[i
];
1725 if (c
== '\n' && print_escape_newlines
)
1730 else if (c
== '\f' && print_escape_newlines
)
1735 else if (c
> '\177')
1737 /* Use octal escapes to avoid encoding issues. */
1739 PRINTCHAR ('0' + ((c
>> 6) & 3));
1740 PRINTCHAR ('0' + ((c
>> 3) & 7));
1741 PRINTCHAR ('0' + (c
& 7));
1745 if (c
== '\"' || c
== '\\')
1754 else if (SUBRP (obj
))
1756 strout ("#<subr ", -1, -1, printcharfun
);
1757 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
);
1760 else if (WINDOWP (obj
))
1762 strout ("#<window ", -1, -1, printcharfun
);
1763 sprintf (buf
, "%"pI
"d", XFASTINT (XWINDOW (obj
)->sequence_number
));
1764 strout (buf
, -1, -1, printcharfun
);
1765 if (!NILP (XWINDOW (obj
)->buffer
))
1767 strout (" on ", -1, -1, printcharfun
);
1768 print_string (BVAR (XBUFFER (XWINDOW (obj
)->buffer
), name
), printcharfun
);
1772 else if (TERMINALP (obj
))
1774 struct terminal
*t
= XTERMINAL (obj
);
1775 strout ("#<terminal ", -1, -1, printcharfun
);
1776 sprintf (buf
, "%d", t
->id
);
1777 strout (buf
, -1, -1, printcharfun
);
1780 strout (" on ", -1, -1, printcharfun
);
1781 strout (t
->name
, -1, -1, printcharfun
);
1785 else if (HASH_TABLE_P (obj
))
1787 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1789 ptrdiff_t real_size
, size
;
1791 strout ("#<hash-table", -1, -1, printcharfun
);
1792 if (SYMBOLP (h
->test
))
1796 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
);
1798 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
);
1800 sprintf (buf
, "%"pD
"d/%"pD
"d", h
->count
, ASIZE (h
->next
));
1801 strout (buf
, -1, -1, printcharfun
);
1803 sprintf (buf
, " %p", h
);
1804 strout (buf
, -1, -1, printcharfun
);
1807 /* Implement a readable output, e.g.:
1808 #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
1809 /* Always print the size. */
1810 sprintf (buf
, "#s(hash-table size %"pD
"d", ASIZE (h
->next
));
1811 strout (buf
, -1, -1, printcharfun
);
1813 if (!NILP (h
->test
))
1815 strout (" test ", -1, -1, printcharfun
);
1816 print_object (h
->test
, printcharfun
, escapeflag
);
1819 if (!NILP (h
->weak
))
1821 strout (" weakness ", -1, -1, printcharfun
);
1822 print_object (h
->weak
, printcharfun
, escapeflag
);
1825 if (!NILP (h
->rehash_size
))
1827 strout (" rehash-size ", -1, -1, printcharfun
);
1828 print_object (h
->rehash_size
, printcharfun
, escapeflag
);
1831 if (!NILP (h
->rehash_threshold
))
1833 strout (" rehash-threshold ", -1, -1, printcharfun
);
1834 print_object (h
->rehash_threshold
, printcharfun
, escapeflag
);
1837 strout (" data ", -1, -1, printcharfun
);
1839 /* Print the data here as a plist. */
1840 real_size
= HASH_TABLE_SIZE (h
);
1843 /* Don't print more elements than the specified maximum. */
1844 if (NATNUMP (Vprint_length
)
1845 && XFASTINT (Vprint_length
) < size
)
1846 size
= XFASTINT (Vprint_length
);
1849 for (i
= 0; i
< size
; i
++)
1850 if (!NILP (HASH_HASH (h
, i
)))
1852 if (i
) PRINTCHAR (' ');
1853 print_object (HASH_KEY (h
, i
), printcharfun
, escapeflag
);
1855 print_object (HASH_VALUE (h
, i
), printcharfun
, escapeflag
);
1858 if (size
< real_size
)
1859 strout (" ...", 4, 4, printcharfun
);
1865 else if (BUFFERP (obj
))
1867 if (NILP (BVAR (XBUFFER (obj
), name
)))
1868 strout ("#<killed buffer>", -1, -1, printcharfun
);
1869 else if (escapeflag
)
1871 strout ("#<buffer ", -1, -1, printcharfun
);
1872 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1876 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1878 else if (WINDOW_CONFIGURATIONP (obj
))
1880 strout ("#<window-configuration>", -1, -1, printcharfun
);
1882 else if (FRAMEP (obj
))
1884 strout ((FRAME_LIVE_P (XFRAME (obj
))
1885 ? "#<frame " : "#<dead frame "),
1886 -1, -1, printcharfun
);
1887 print_string (XFRAME (obj
)->name
, printcharfun
);
1888 sprintf (buf
, " %p", XFRAME (obj
));
1889 strout (buf
, -1, -1, printcharfun
);
1892 else if (FONTP (obj
))
1896 if (! FONT_OBJECT_P (obj
))
1898 if (FONT_SPEC_P (obj
))
1899 strout ("#<font-spec", -1, -1, printcharfun
);
1901 strout ("#<font-entity", -1, -1, printcharfun
);
1902 for (i
= 0; i
< FONT_SPEC_MAX
; i
++)
1905 if (i
< FONT_WEIGHT_INDEX
|| i
> FONT_WIDTH_INDEX
)
1906 print_object (AREF (obj
, i
), printcharfun
, escapeflag
);
1908 print_object (font_style_symbolic (obj
, i
, 0),
1909 printcharfun
, escapeflag
);
1914 strout ("#<font-object ", -1, -1, printcharfun
);
1915 print_object (AREF (obj
, FONT_NAME_INDEX
), printcharfun
,
1922 ptrdiff_t size
= ASIZE (obj
);
1923 if (COMPILEDP (obj
))
1926 size
&= PSEUDOVECTOR_SIZE_MASK
;
1928 if (CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
))
1930 /* We print a char-table as if it were a vector,
1931 lumping the parent and default slots in with the
1932 character slots. But we add #^ as a prefix. */
1934 /* Make each lowest sub_char_table start a new line.
1935 Otherwise we'll make a line extremely long, which
1936 results in slow redisplay. */
1937 if (SUB_CHAR_TABLE_P (obj
)
1938 && XINT (XSUB_CHAR_TABLE (obj
)->depth
) == 3)
1942 if (SUB_CHAR_TABLE_P (obj
))
1944 size
&= PSEUDOVECTOR_SIZE_MASK
;
1946 if (size
& PSEUDOVECTOR_FLAG
)
1952 register Lisp_Object tem
;
1953 ptrdiff_t real_size
= size
;
1955 /* Don't print more elements than the specified maximum. */
1956 if (NATNUMP (Vprint_length
)
1957 && XFASTINT (Vprint_length
) < size
)
1958 size
= XFASTINT (Vprint_length
);
1960 for (i
= 0; i
< size
; i
++)
1962 if (i
) PRINTCHAR (' ');
1963 tem
= XVECTOR (obj
)->contents
[i
];
1964 print_object (tem
, printcharfun
, escapeflag
);
1966 if (size
< real_size
)
1967 strout (" ...", 4, 4, printcharfun
);
1974 switch (XMISCTYPE (obj
))
1976 case Lisp_Misc_Marker
:
1977 strout ("#<marker ", -1, -1, printcharfun
);
1978 /* Do you think this is necessary? */
1979 if (XMARKER (obj
)->insertion_type
!= 0)
1980 strout ("(moves after insertion) ", -1, -1, printcharfun
);
1981 if (! XMARKER (obj
)->buffer
)
1982 strout ("in no buffer", -1, -1, printcharfun
);
1985 sprintf (buf
, "at %"pD
"d", marker_position (obj
));
1986 strout (buf
, -1, -1, printcharfun
);
1987 strout (" in ", -1, -1, printcharfun
);
1988 print_string (BVAR (XMARKER (obj
)->buffer
, name
), printcharfun
);
1993 case Lisp_Misc_Overlay
:
1994 strout ("#<overlay ", -1, -1, printcharfun
);
1995 if (! XMARKER (OVERLAY_START (obj
))->buffer
)
1996 strout ("in no buffer", -1, -1, printcharfun
);
1999 sprintf (buf
, "from %"pD
"d to %"pD
"d in ",
2000 marker_position (OVERLAY_START (obj
)),
2001 marker_position (OVERLAY_END (obj
)));
2002 strout (buf
, -1, -1, printcharfun
);
2003 print_string (BVAR (XMARKER (OVERLAY_START (obj
))->buffer
, name
),
2009 /* Remaining cases shouldn't happen in normal usage, but let's print
2010 them anyway for the benefit of the debugger. */
2011 case Lisp_Misc_Free
:
2012 strout ("#<misc free cell>", -1, -1, printcharfun
);
2015 case Lisp_Misc_Save_Value
:
2016 strout ("#<save_value ", -1, -1, printcharfun
);
2017 sprintf (buf
, "ptr=%p int=%"pD
"d",
2018 XSAVE_VALUE (obj
)->pointer
,
2019 XSAVE_VALUE (obj
)->integer
);
2020 strout (buf
, -1, -1, printcharfun
);
2032 /* We're in trouble if this happens!
2033 Probably should just abort () */
2034 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
);
2036 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2037 else if (VECTORLIKEP (obj
))
2038 sprintf (buf
, "(PVEC 0x%08"pD
"x)", ASIZE (obj
));
2040 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2041 strout (buf
, -1, -1, printcharfun
);
2042 strout (" Save your buffers immediately and please report this bug>",
2043 -1, -1, printcharfun
);
2051 /* Print a description of INTERVAL using PRINTCHARFUN.
2052 This is part of printing a string that has text properties. */
2055 print_interval (INTERVAL interval
, Lisp_Object printcharfun
)
2057 if (NILP (interval
->plist
))
2060 print_object (make_number (interval
->position
), printcharfun
, 1);
2062 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2065 print_object (interval
->plist
, printcharfun
, 1);
2070 syms_of_print (void)
2072 DEFSYM (Qtemp_buffer_setup_hook
, "temp-buffer-setup-hook");
2074 DEFVAR_LISP ("standard-output", Vstandard_output
,
2075 doc
: /* Output stream `print' uses by default for outputting a character.
2076 This may be any function of one argument.
2077 It may also be a buffer (output is inserted before point)
2078 or a marker (output is inserted and the marker is advanced)
2079 or the symbol t (output appears in the echo area). */);
2080 Vstandard_output
= Qt
;
2081 DEFSYM (Qstandard_output
, "standard-output");
2083 DEFVAR_LISP ("float-output-format", Vfloat_output_format
,
2084 doc
: /* The format descriptor string used to print floats.
2085 This is a %-spec like those accepted by `printf' in C,
2086 but with some restrictions. It must start with the two characters `%.'.
2087 After that comes an integer precision specification,
2088 and then a letter which controls the format.
2089 The letters allowed are `e', `f' and `g'.
2090 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2091 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2092 Use `g' to choose the shorter of those two formats for the number at hand.
2093 The precision in any of these cases is the number of digits following
2094 the decimal point. With `f', a precision of 0 means to omit the
2095 decimal point. 0 is not allowed with `e' or `g'.
2097 A value of nil means to use the shortest notation
2098 that represents the number without losing information. */);
2099 Vfloat_output_format
= Qnil
;
2100 DEFSYM (Qfloat_output_format
, "float-output-format");
2102 DEFVAR_LISP ("print-length", Vprint_length
,
2103 doc
: /* Maximum length of list to print before abbreviating.
2104 A value of nil means no limit. See also `eval-expression-print-length'. */);
2105 Vprint_length
= Qnil
;
2107 DEFVAR_LISP ("print-level", Vprint_level
,
2108 doc
: /* Maximum depth of list nesting to print before abbreviating.
2109 A value of nil means no limit. See also `eval-expression-print-level'. */);
2110 Vprint_level
= Qnil
;
2112 DEFVAR_BOOL ("print-escape-newlines", print_escape_newlines
,
2113 doc
: /* Non-nil means print newlines in strings as `\\n'.
2114 Also print formfeeds as `\\f'. */);
2115 print_escape_newlines
= 0;
2117 DEFVAR_BOOL ("print-escape-nonascii", print_escape_nonascii
,
2118 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2119 \(OOO is the octal representation of the character code.)
2120 Only single-byte characters are affected, and only in `prin1'.
2121 When the output goes in a multibyte buffer, this feature is
2122 enabled regardless of the value of the variable. */);
2123 print_escape_nonascii
= 0;
2125 DEFVAR_BOOL ("print-escape-multibyte", print_escape_multibyte
,
2126 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2127 \(XXXX is the hex representation of the character code.)
2128 This affects only `prin1'. */);
2129 print_escape_multibyte
= 0;
2131 DEFVAR_BOOL ("print-quoted", print_quoted
,
2132 doc
: /* Non-nil means print quoted forms with reader syntax.
2133 I.e., (quote foo) prints as 'foo, (function foo) as #'foo. */);
2136 DEFVAR_LISP ("print-gensym", Vprint_gensym
,
2137 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2138 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2139 When the uninterned symbol appears within a recursive data structure,
2140 and the symbol appears more than once, in addition use the #N# and #N=
2141 constructs as needed, so that multiple references to the same symbol are
2142 shared once again when the text is read back. */);
2143 Vprint_gensym
= Qnil
;
2145 DEFVAR_LISP ("print-circle", Vprint_circle
,
2146 doc
: /* *Non-nil means print recursive structures using #N= and #N# syntax.
2147 If nil, printing proceeds recursively and may lead to
2148 `max-lisp-eval-depth' being exceeded or an error may occur:
2149 \"Apparently circular structure being printed.\" Also see
2150 `print-length' and `print-level'.
2151 If non-nil, shared substructures anywhere in the structure are printed
2152 with `#N=' before the first occurrence (in the order of the print
2153 representation) and `#N#' in place of each subsequent occurrence,
2154 where N is a positive decimal integer. */);
2155 Vprint_circle
= Qnil
;
2157 DEFVAR_LISP ("print-continuous-numbering", Vprint_continuous_numbering
,
2158 doc
: /* *Non-nil means number continuously across print calls.
2159 This affects the numbers printed for #N= labels and #M# references.
2160 See also `print-circle', `print-gensym', and `print-number-table'.
2161 This variable should not be set with `setq'; bind it with a `let' instead. */);
2162 Vprint_continuous_numbering
= Qnil
;
2164 DEFVAR_LISP ("print-number-table", Vprint_number_table
,
2165 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2166 The Lisp printer uses this vector to detect Lisp objects referenced more
2169 When you bind `print-continuous-numbering' to t, you should probably
2170 also bind `print-number-table' to nil. This ensures that the value of
2171 `print-number-table' can be garbage-collected once the printing is
2172 done. If all elements of `print-number-table' are nil, it means that
2173 the printing done so far has not found any shared structure or objects
2174 that need to be recorded in the table. */);
2175 Vprint_number_table
= Qnil
;
2177 DEFVAR_LISP ("print-charset-text-property", Vprint_charset_text_property
,
2178 doc
: /* A flag to control printing of `charset' text property on printing a string.
2179 The value must be nil, t, or `default'.
2181 If the value is nil, don't print the text property `charset'.
2183 If the value is t, always print the text property `charset'.
2185 If the value is `default', print the text property `charset' only when
2186 the value is different from what is guessed in the current charset
2188 Vprint_charset_text_property
= Qdefault
;
2190 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2191 staticpro (&Vprin1_to_string_buffer
);
2194 defsubr (&Sprin1_to_string
);
2195 defsubr (&Serror_message_string
);
2199 defsubr (&Swrite_char
);
2200 defsubr (&Sexternal_debugging_output
);
2201 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2202 defsubr (&Sredirect_debugging_output
);
2205 DEFSYM (Qexternal_debugging_output
, "external-debugging-output");
2206 DEFSYM (Qprint_escape_newlines
, "print-escape-newlines");
2207 DEFSYM (Qprint_escape_multibyte
, "print-escape-multibyte");
2208 DEFSYM (Qprint_escape_nonascii
, "print-escape-nonascii");
2210 print_prune_charset_plist
= Qnil
;
2211 staticpro (&print_prune_charset_plist
);