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 Lisp_Object Qtemp_buffer_setup_hook
;
44 /* These are used to print like we read. */
46 Lisp_Object Qfloat_output_format
;
55 /* Default to values appropriate for IEEE floating point. */
60 /* Avoid actual stack overflow in print. */
63 /* Level of nesting inside outputting backquote in new style. */
64 int new_backquote_output
;
66 /* Detect most circularities to print finite output. */
67 #define PRINT_CIRCLE 200
68 Lisp_Object being_printed
[PRINT_CIRCLE
];
70 /* When printing into a buffer, first we put the text in this
71 block, then insert it all at once. */
74 /* Size allocated in print_buffer. */
75 EMACS_INT print_buffer_size
;
76 /* Chars stored in print_buffer. */
77 EMACS_INT print_buffer_pos
;
78 /* Bytes stored in print_buffer. */
79 EMACS_INT print_buffer_pos_byte
;
81 Lisp_Object Qprint_escape_newlines
;
82 Lisp_Object Qprint_escape_multibyte
, Qprint_escape_nonascii
;
84 /* Vprint_number_table is a table, that keeps objects that are going to
85 be printed, to allow use of #n= and #n# to express sharing.
86 For any given object, the table can give the following values:
87 t the object will be printed only once.
88 -N the object will be printed several times and will take number N.
89 N the object has been printed so we can refer to it as #N#.
90 print_number_index holds the largest N already used.
91 N has to be striclty larger than 0 since we need to distinguish -N. */
92 int print_number_index
;
93 void print_interval (INTERVAL interval
, Lisp_Object printcharfun
);
95 /* GDB resets this to zero on W32 to disable OutputDebugString calls. */
96 int print_output_debug_flag EXTERNALLY_VISIBLE
= 1;
99 /* Low level output routines for characters and strings */
101 /* Lisp functions to do output using a stream
102 must have the stream in a variable called printcharfun
103 and must start with PRINTPREPARE, end with PRINTFINISH,
104 and use PRINTDECLARE to declare common variables.
105 Use PRINTCHAR to output one character,
106 or call strout to output a block of characters. */
108 #define PRINTDECLARE \
109 struct buffer *old = current_buffer; \
110 EMACS_INT old_point = -1, start_point = -1; \
111 EMACS_INT old_point_byte = -1, start_point_byte = -1; \
112 int specpdl_count = SPECPDL_INDEX (); \
113 int free_print_buffer = 0; \
114 int multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters)); \
117 #define PRINTPREPARE \
118 original = printcharfun; \
119 if (NILP (printcharfun)) printcharfun = Qt; \
120 if (BUFFERP (printcharfun)) \
122 if (XBUFFER (printcharfun) != current_buffer) \
123 Fset_buffer (printcharfun); \
124 printcharfun = Qnil; \
126 if (MARKERP (printcharfun)) \
128 EMACS_INT marker_pos; \
129 if (! XMARKER (printcharfun)->buffer) \
130 error ("Marker does not point anywhere"); \
131 if (XMARKER (printcharfun)->buffer != current_buffer) \
132 set_buffer_internal (XMARKER (printcharfun)->buffer); \
133 marker_pos = marker_position (printcharfun); \
134 if (marker_pos < BEGV || marker_pos > ZV) \
135 error ("Marker is outside the accessible part of the buffer"); \
137 old_point_byte = PT_BYTE; \
138 SET_PT_BOTH (marker_pos, \
139 marker_byte_position (printcharfun)); \
141 start_point_byte = PT_BYTE; \
142 printcharfun = Qnil; \
144 if (NILP (printcharfun)) \
146 Lisp_Object string; \
147 if (NILP (BVAR (current_buffer, enable_multibyte_characters)) \
148 && ! print_escape_multibyte) \
149 specbind (Qprint_escape_multibyte, Qt); \
150 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)) \
151 && ! print_escape_nonascii) \
152 specbind (Qprint_escape_nonascii, Qt); \
153 if (print_buffer != 0) \
155 string = make_string_from_bytes (print_buffer, \
157 print_buffer_pos_byte); \
158 record_unwind_protect (print_unwind, string); \
162 print_buffer_size = 1000; \
163 print_buffer = (char *) xmalloc (print_buffer_size); \
164 free_print_buffer = 1; \
166 print_buffer_pos = 0; \
167 print_buffer_pos_byte = 0; \
169 if (EQ (printcharfun, Qt) && ! noninteractive) \
170 setup_echo_area_for_printing (multibyte);
172 #define PRINTFINISH \
173 if (NILP (printcharfun)) \
175 if (print_buffer_pos != print_buffer_pos_byte \
176 && NILP (BVAR (current_buffer, enable_multibyte_characters))) \
178 unsigned char *temp \
179 = (unsigned char *) alloca (print_buffer_pos + 1); \
180 copy_text ((unsigned char *) print_buffer, temp, \
181 print_buffer_pos_byte, 1, 0); \
182 insert_1_both ((char *) temp, print_buffer_pos, \
183 print_buffer_pos, 0, 1, 0); \
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 if (print_buffer_pos_byte
+ len
>= print_buffer_size
)
239 print_buffer
= (char *) xrealloc (print_buffer
,
240 print_buffer_size
*= 2);
241 memcpy (print_buffer
+ print_buffer_pos_byte
, str
, len
);
242 print_buffer_pos
+= 1;
243 print_buffer_pos_byte
+= len
;
245 else if (noninteractive
)
247 fwrite (str
, 1, len
, stdout
);
248 noninteractive_need_newline
= 1;
253 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
255 setup_echo_area_for_printing (multibyte_p
);
257 message_dolog ((char *) str
, len
, 0, multibyte_p
);
263 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
264 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
265 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
266 print_buffer. PRINTCHARFUN t means output to the echo area or to
267 stdout if non-interactive. If neither nil nor t, call Lisp
268 function PRINTCHARFUN for each character printed. MULTIBYTE
269 non-zero means PTR contains multibyte characters.
271 In the case where PRINTCHARFUN is nil, it is safe for PTR to point
272 to data in a Lisp string. Otherwise that is not safe. */
275 strout (const char *ptr
, EMACS_INT size
, EMACS_INT size_byte
,
276 Lisp_Object printcharfun
)
279 size_byte
= size
= strlen (ptr
);
281 if (NILP (printcharfun
))
283 if (print_buffer_pos_byte
+ size_byte
> print_buffer_size
)
285 print_buffer_size
= print_buffer_size
* 2 + size_byte
;
286 print_buffer
= (char *) xrealloc (print_buffer
,
289 memcpy (print_buffer
+ print_buffer_pos_byte
, ptr
, size_byte
);
290 print_buffer_pos
+= size
;
291 print_buffer_pos_byte
+= size_byte
;
293 else if (noninteractive
&& EQ (printcharfun
, Qt
))
295 fwrite (ptr
, 1, size_byte
, stdout
);
296 noninteractive_need_newline
= 1;
298 else if (EQ (printcharfun
, Qt
))
300 /* Output to echo area. We're trying to avoid a little overhead
301 here, that's the reason we don't call printchar to do the
305 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
307 setup_echo_area_for_printing (multibyte_p
);
308 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
310 if (size
== size_byte
)
312 for (i
= 0; i
< size
; ++i
)
313 insert_char ((unsigned char) *ptr
++);
318 for (i
= 0; i
< size_byte
; i
+= len
)
320 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
328 /* PRINTCHARFUN is a Lisp function. */
331 if (size
== size_byte
)
333 while (i
< size_byte
)
341 while (i
< size_byte
)
343 /* Here, we must convert each multi-byte form to the
344 corresponding character code before handing it to
347 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
356 /* Print the contents of a string STRING using PRINTCHARFUN.
357 It isn't safe to use strout in many cases,
358 because printing one char can relocate. */
361 print_string (Lisp_Object string
, Lisp_Object printcharfun
)
363 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
367 if (print_escape_nonascii
)
368 string
= string_escape_byte8 (string
);
370 if (STRING_MULTIBYTE (string
))
371 chars
= SCHARS (string
);
372 else if (! print_escape_nonascii
373 && (EQ (printcharfun
, Qt
)
374 ? ! NILP (BVAR (&buffer_defaults
, enable_multibyte_characters
))
375 : ! NILP (BVAR (current_buffer
, enable_multibyte_characters
))))
377 /* If unibyte string STRING contains 8-bit codes, we must
378 convert STRING to a multibyte string containing the same
383 chars
= SBYTES (string
);
384 bytes
= parse_str_to_multibyte (SDATA (string
), chars
);
387 newstr
= make_uninit_multibyte_string (chars
, bytes
);
388 memcpy (SDATA (newstr
), SDATA (string
), chars
);
389 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
394 chars
= SBYTES (string
);
396 if (EQ (printcharfun
, Qt
))
398 /* Output to echo area. */
399 EMACS_INT nbytes
= SBYTES (string
);
402 /* Copy the string contents so that relocation of STRING by
403 GC does not cause trouble. */
406 SAFE_ALLOCA (buffer
, char *, nbytes
);
407 memcpy (buffer
, SDATA (string
), nbytes
);
409 strout (buffer
, chars
, SBYTES (string
), printcharfun
);
414 /* No need to copy, since output to print_buffer can't GC. */
415 strout (SSDATA (string
), chars
, SBYTES (string
), printcharfun
);
419 /* Otherwise, string may be relocated by printing one char.
420 So re-fetch the string address for each character. */
422 EMACS_INT size
= SCHARS (string
);
423 EMACS_INT size_byte
= SBYTES (string
);
426 if (size
== size_byte
)
427 for (i
= 0; i
< size
; i
++)
428 PRINTCHAR (SREF (string
, i
));
430 for (i
= 0; i
< size_byte
; )
432 /* Here, we must convert each multi-byte form to the
433 corresponding character code before handing it to PRINTCHAR. */
435 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
, len
);
443 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
444 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
445 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
446 (Lisp_Object character
, Lisp_Object printcharfun
)
450 if (NILP (printcharfun
))
451 printcharfun
= Vstandard_output
;
452 CHECK_NUMBER (character
);
454 PRINTCHAR (XINT (character
));
459 /* Used from outside of print.c to print a block of SIZE
460 single-byte chars at DATA on the default output stream.
461 Do not use this on the contents of a Lisp string. */
464 write_string (const char *data
, int size
)
467 Lisp_Object printcharfun
;
469 printcharfun
= Vstandard_output
;
472 strout (data
, size
, size
, printcharfun
);
476 /* Used to print a block of SIZE single-byte chars at DATA on a
477 specified stream PRINTCHARFUN.
478 Do not use this on the contents of a Lisp string. */
481 write_string_1 (const char *data
, int size
, Lisp_Object printcharfun
)
486 strout (data
, size
, size
, printcharfun
);
492 temp_output_buffer_setup (const char *bufname
)
494 int count
= SPECPDL_INDEX ();
495 register struct buffer
*old
= current_buffer
;
496 register Lisp_Object buf
;
498 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
500 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
502 Fkill_all_local_variables ();
503 delete_all_overlays (current_buffer
);
504 BVAR (current_buffer
, directory
) = BVAR (old
, directory
);
505 BVAR (current_buffer
, read_only
) = Qnil
;
506 BVAR (current_buffer
, filename
) = Qnil
;
507 BVAR (current_buffer
, undo_list
) = Qt
;
508 eassert (current_buffer
->overlays_before
== NULL
);
509 eassert (current_buffer
->overlays_after
== NULL
);
510 BVAR (current_buffer
, enable_multibyte_characters
)
511 = BVAR (&buffer_defaults
, enable_multibyte_characters
);
512 specbind (Qinhibit_read_only
, Qt
);
513 specbind (Qinhibit_modification_hooks
, Qt
);
515 XSETBUFFER (buf
, current_buffer
);
517 Frun_hooks (1, &Qtemp_buffer_setup_hook
);
519 unbind_to (count
, Qnil
);
521 specbind (Qstandard_output
, buf
);
525 internal_with_output_to_temp_buffer (const char *bufname
, Lisp_Object (*function
) (Lisp_Object
), Lisp_Object args
)
527 int count
= SPECPDL_INDEX ();
528 Lisp_Object buf
, val
;
532 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
533 temp_output_buffer_setup (bufname
);
534 buf
= Vstandard_output
;
537 val
= (*function
) (args
);
540 temp_output_buffer_show (buf
);
543 return unbind_to (count
, val
);
546 DEFUN ("with-output-to-temp-buffer",
547 Fwith_output_to_temp_buffer
, Swith_output_to_temp_buffer
,
549 doc
: /* Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
551 This construct makes buffer BUFNAME empty before running BODY.
552 It does not make the buffer current for BODY.
553 Instead it binds `standard-output' to that buffer, so that output
554 generated with `prin1' and similar functions in BODY goes into
557 At the end of BODY, this marks buffer BUFNAME unmodifed and displays
558 it in a window, but does not select it. The normal way to do this is
559 by calling `display-buffer', then running `temp-buffer-show-hook'.
560 However, if `temp-buffer-show-function' is non-nil, it calls that
561 function instead (and does not run `temp-buffer-show-hook'). The
562 function gets one argument, the buffer to display.
564 The return value of `with-output-to-temp-buffer' is the value of the
565 last form in BODY. If BODY does not finish normally, the buffer
566 BUFNAME is not displayed.
568 This runs the hook `temp-buffer-setup-hook' before BODY,
569 with the buffer BUFNAME temporarily current. It runs the hook
570 `temp-buffer-show-hook' after displaying buffer BUFNAME, with that
571 buffer temporarily current, and the window that was used to display it
572 temporarily selected. But it doesn't run `temp-buffer-show-hook'
573 if it uses `temp-buffer-show-function'.
575 usage: (with-output-to-temp-buffer BUFNAME BODY...) */)
580 int count
= SPECPDL_INDEX ();
581 Lisp_Object buf
, val
;
584 name
= Feval (Fcar (args
));
586 temp_output_buffer_setup (SSDATA (name
));
587 buf
= Vstandard_output
;
590 val
= Fprogn (XCDR (args
));
593 temp_output_buffer_show (buf
);
596 return unbind_to (count
, val
);
600 static void print (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
);
601 static void print_preprocess (Lisp_Object obj
);
602 static void print_preprocess_string (INTERVAL interval
, Lisp_Object arg
);
603 static void print_object (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
);
605 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
606 doc
: /* Output a newline to stream PRINTCHARFUN.
607 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
608 (Lisp_Object printcharfun
)
612 if (NILP (printcharfun
))
613 printcharfun
= Vstandard_output
;
620 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
621 doc
: /* Output the printed representation of OBJECT, any Lisp object.
622 Quoting characters are printed when needed to make output that `read'
623 can handle, whenever this is possible. For complex objects, the behavior
624 is controlled by `print-level' and `print-length', which see.
626 OBJECT is any of the Lisp data types: a number, a string, a symbol,
627 a list, a buffer, a window, a frame, etc.
629 A printed representation of an object is text which describes that object.
631 Optional argument PRINTCHARFUN is the output stream, which can be one
634 - a buffer, in which case output is inserted into that buffer at point;
635 - a marker, in which case output is inserted at marker's position;
636 - a function, in which case that function is called once for each
637 character of OBJECT's printed representation;
638 - a symbol, in which case that symbol's function definition is called; or
639 - t, in which case the output is displayed in the echo area.
641 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
643 (Lisp_Object object
, Lisp_Object printcharfun
)
647 if (NILP (printcharfun
))
648 printcharfun
= Vstandard_output
;
650 print (object
, printcharfun
, 1);
655 /* a buffer which is used to hold output being built by prin1-to-string */
656 Lisp_Object Vprin1_to_string_buffer
;
658 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
659 doc
: /* Return a string containing the printed representation of OBJECT.
660 OBJECT can be any Lisp object. This function outputs quoting characters
661 when necessary to make output that `read' can handle, whenever possible,
662 unless the optional second argument NOESCAPE is non-nil. For complex objects,
663 the behavior is controlled by `print-level' and `print-length', which see.
665 OBJECT is any of the Lisp data types: a number, a string, a symbol,
666 a list, a buffer, a window, a frame, etc.
668 A printed representation of an object is text which describes that object. */)
669 (Lisp_Object object
, Lisp_Object noescape
)
671 Lisp_Object printcharfun
;
672 /* struct gcpro gcpro1, gcpro2; */
673 Lisp_Object save_deactivate_mark
;
674 int count
= SPECPDL_INDEX ();
675 struct buffer
*previous
;
677 specbind (Qinhibit_modification_hooks
, Qt
);
682 /* Save and restore this--we are altering a buffer
683 but we don't want to deactivate the mark just for that.
684 No need for specbind, since errors deactivate the mark. */
685 save_deactivate_mark
= Vdeactivate_mark
;
686 /* GCPRO2 (object, save_deactivate_mark); */
689 printcharfun
= Vprin1_to_string_buffer
;
691 print (object
, printcharfun
, NILP (noescape
));
692 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
696 previous
= current_buffer
;
697 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
698 object
= Fbuffer_string ();
699 if (SBYTES (object
) == SCHARS (object
))
700 STRING_SET_UNIBYTE (object
);
702 /* Note that this won't make prepare_to_modify_buffer call
703 ask-user-about-supersession-threat because this buffer
704 does not visit a file. */
706 set_buffer_internal (previous
);
708 Vdeactivate_mark
= save_deactivate_mark
;
712 return unbind_to (count
, object
);
715 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
716 doc
: /* Output the printed representation of OBJECT, any Lisp object.
717 No quoting characters are used; no delimiters are printed around
718 the contents of strings.
720 OBJECT is any of the Lisp data types: a number, a string, a symbol,
721 a list, a buffer, a window, a frame, etc.
723 A printed representation of an object is text which describes that object.
725 Optional argument PRINTCHARFUN is the output stream, which can be one
728 - a buffer, in which case output is inserted into that buffer at point;
729 - a marker, in which case output is inserted at marker's position;
730 - a function, in which case that function is called once for each
731 character of OBJECT's printed representation;
732 - a symbol, in which case that symbol's function definition is called; or
733 - t, in which case the output is displayed in the echo area.
735 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
737 (Lisp_Object object
, Lisp_Object printcharfun
)
741 if (NILP (printcharfun
))
742 printcharfun
= Vstandard_output
;
744 print (object
, printcharfun
, 0);
749 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
750 doc
: /* Output the printed representation of OBJECT, with newlines around it.
751 Quoting characters are printed when needed to make output that `read'
752 can handle, whenever this is possible. For complex objects, the behavior
753 is controlled by `print-level' and `print-length', which see.
755 OBJECT is any of the Lisp data types: a number, a string, a symbol,
756 a list, a buffer, a window, a frame, etc.
758 A printed representation of an object is text which describes that object.
760 Optional argument PRINTCHARFUN is the output stream, which can be one
763 - a buffer, in which case output is inserted into that buffer at point;
764 - a marker, in which case output is inserted at marker's position;
765 - a function, in which case that function is called once for each
766 character of OBJECT's printed representation;
767 - a symbol, in which case that symbol's function definition is called; or
768 - t, in which case the output is displayed in the echo area.
770 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
772 (Lisp_Object object
, Lisp_Object printcharfun
)
777 if (NILP (printcharfun
))
778 printcharfun
= Vstandard_output
;
782 print (object
, printcharfun
, 1);
789 /* The subroutine object for external-debugging-output is kept here
790 for the convenience of the debugger. */
791 Lisp_Object Qexternal_debugging_output
;
793 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
794 doc
: /* Write CHARACTER to stderr.
795 You can call print while debugging emacs, and pass it this function
796 to make it write to the debugging output. */)
797 (Lisp_Object character
)
799 CHECK_NUMBER (character
);
800 putc ((int) XINT (character
), stderr
);
803 /* Send the output to a debugger (nothing happens if there isn't one). */
804 if (print_output_debug_flag
)
806 char buf
[2] = {(char) XINT (character
), '\0'};
807 OutputDebugString (buf
);
814 /* This function is never called. Its purpose is to prevent
815 print_output_debug_flag from being optimized away. */
818 debug_output_compilation_hack (int x
)
820 print_output_debug_flag
= x
;
823 #if defined (GNU_LINUX)
825 /* This functionality is not vitally important in general, so we rely on
826 non-portable ability to use stderr as lvalue. */
828 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
830 FILE *initial_stderr_stream
= NULL
;
832 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
834 "FDebug output file: \nP",
835 doc
: /* Redirect debugging output (stderr stream) to file FILE.
836 If FILE is nil, reset target to the initial stderr stream.
837 Optional arg APPEND non-nil (interactively, with prefix arg) means
838 append to existing target file. */)
839 (Lisp_Object file
, Lisp_Object append
)
841 if (initial_stderr_stream
!= NULL
)
847 stderr
= initial_stderr_stream
;
848 initial_stderr_stream
= NULL
;
852 file
= Fexpand_file_name (file
, Qnil
);
853 initial_stderr_stream
= stderr
;
854 stderr
= fopen (SSDATA (file
), NILP (append
) ? "w" : "a");
857 stderr
= initial_stderr_stream
;
858 initial_stderr_stream
= NULL
;
859 report_file_error ("Cannot open debugging output stream",
865 #endif /* GNU_LINUX */
868 /* This is the interface for debugging printing. */
871 debug_print (Lisp_Object arg
)
873 Fprin1 (arg
, Qexternal_debugging_output
);
874 fprintf (stderr
, "\r\n");
878 safe_debug_print (Lisp_Object arg
)
880 int valid
= valid_lisp_object_p (arg
);
885 fprintf (stderr
, "#<%s_LISP_OBJECT 0x%08lx>\r\n",
886 !valid
? "INVALID" : "SOME",
887 (unsigned long) XHASH (arg
)
892 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
894 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
895 See Info anchor `(elisp)Definition of signal' for some details on how this
896 error message is constructed. */)
899 struct buffer
*old
= current_buffer
;
903 /* If OBJ is (error STRING), just return STRING.
904 That is not only faster, it also avoids the need to allocate
905 space here when the error is due to memory full. */
906 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
907 && CONSP (XCDR (obj
))
908 && STRINGP (XCAR (XCDR (obj
)))
909 && NILP (XCDR (XCDR (obj
))))
910 return XCAR (XCDR (obj
));
912 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
914 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
915 value
= Fbuffer_string ();
919 set_buffer_internal (old
);
925 /* Print an error message for the error DATA onto Lisp output stream
926 STREAM (suitable for the print functions).
927 CONTEXT is a C string describing the context of the error.
928 CALLER is the Lisp function inside which the error was signaled. */
931 print_error_message (Lisp_Object data
, Lisp_Object stream
, const char *context
,
934 Lisp_Object errname
, errmsg
, file_error
, tail
;
939 write_string_1 (context
, -1, stream
);
941 /* If we know from where the error was signaled, show it in
943 if (!NILP (caller
) && SYMBOLP (caller
))
945 Lisp_Object cname
= SYMBOL_NAME (caller
);
946 char *name
= alloca (SBYTES (cname
));
947 memcpy (name
, SDATA (cname
), SBYTES (cname
));
948 message_dolog (name
, SBYTES (cname
), 0, 0);
949 message_dolog (": ", 2, 0, 0);
952 errname
= Fcar (data
);
954 if (EQ (errname
, Qerror
))
959 errmsg
= Fcar (data
);
964 Lisp_Object error_conditions
;
965 errmsg
= Fget (errname
, Qerror_message
);
966 error_conditions
= Fget (errname
, Qerror_conditions
);
967 file_error
= Fmemq (Qfile_error
, error_conditions
);
970 /* Print an error message including the data items. */
972 tail
= Fcdr_safe (data
);
975 /* For file-error, make error message by concatenating
976 all the data items. They are all strings. */
977 if (!NILP (file_error
) && CONSP (tail
))
978 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
980 if (STRINGP (errmsg
))
981 Fprinc (errmsg
, stream
);
983 write_string_1 ("peculiar error", -1, stream
);
985 for (i
= 0; CONSP (tail
); tail
= XCDR (tail
), i
++)
989 write_string_1 (i
? ", " : ": ", 2, stream
);
991 if (!NILP (file_error
) || EQ (errname
, Qend_of_file
))
992 Fprinc (obj
, stream
);
994 Fprin1 (obj
, stream
);
1003 * The buffer should be at least as large as the max string size of the
1004 * largest float, printed in the biggest notation. This is undoubtedly
1005 * 20d float_output_format, with the negative of the C-constant "HUGE"
1008 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
1010 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
1011 * case of -1e307 in 20d float_output_format. What is one to do (short of
1012 * re-writing _doprnt to be more sane)?
1014 * Given the above, the buffer must be least FLOAT_TO_STRING_BUFSIZE bytes.
1018 float_to_string (char *buf
, double data
)
1023 /* Check for plus infinity in a way that won't lose
1024 if there is no plus infinity. */
1025 if (data
== data
/ 2 && data
> 1.0)
1027 strcpy (buf
, "1.0e+INF");
1030 /* Likewise for minus infinity. */
1031 if (data
== data
/ 2 && data
< -1.0)
1033 strcpy (buf
, "-1.0e+INF");
1036 /* Check for NaN in a way that won't fail if there are no NaNs. */
1037 if (! (data
* 0.0 >= 0.0))
1039 /* Prepend "-" if the NaN's sign bit is negative.
1040 The sign bit of a double is the bit that is 1 in -0.0. */
1042 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
1044 u_minus_zero
.d
= - 0.0;
1045 for (i
= 0; i
< sizeof (double); i
++)
1046 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
1052 strcpy (buf
, "0.0e+NaN");
1056 if (NILP (Vfloat_output_format
)
1057 || !STRINGP (Vfloat_output_format
))
1060 /* Generate the fewest number of digits that represent the
1061 floating point value without losing information. */
1062 dtoastr (buf
, FLOAT_TO_STRING_BUFSIZE
- 2, 0, 0, data
);
1063 /* The decimal point must be printed, or the byte compiler can
1064 get confused (Bug#8033). */
1067 else /* oink oink */
1069 /* Check that the spec we have is fully valid.
1070 This means not only valid for printf,
1071 but meant for floats, and reasonable. */
1072 cp
= SSDATA (Vfloat_output_format
);
1081 /* Check the width specification. */
1083 if ('0' <= *cp
&& *cp
<= '9')
1087 width
= (width
* 10) + (*cp
++ - '0');
1088 while (*cp
>= '0' && *cp
<= '9');
1090 /* A precision of zero is valid only for %f. */
1092 || (width
== 0 && *cp
!= 'f'))
1096 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1102 sprintf (buf
, SSDATA (Vfloat_output_format
), data
);
1105 /* Make sure there is a decimal point with digit after, or an
1106 exponent, so that the value is readable as a float. But don't do
1107 this with "%.0f"; it's valid for that not to produce a decimal
1108 point. Note that width can be 0 only for %.0f. */
1111 for (cp
= buf
; *cp
; cp
++)
1112 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1115 if (*cp
== '.' && cp
[1] == 0)
1131 print (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
)
1133 new_backquote_output
= 0;
1135 /* Reset print_number_index and Vprint_number_table only when
1136 the variable Vprint_continuous_numbering is nil. Otherwise,
1137 the values of these variables will be kept between several
1139 if (NILP (Vprint_continuous_numbering
)
1140 || NILP (Vprint_number_table
))
1142 print_number_index
= 0;
1143 Vprint_number_table
= Qnil
;
1146 /* Construct Vprint_number_table for print-gensym and print-circle. */
1147 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1149 /* Construct Vprint_number_table.
1150 This increments print_number_index for the objects added. */
1152 print_preprocess (obj
);
1154 if (HASH_TABLE_P (Vprint_number_table
))
1155 { /* Remove unnecessary objects, which appear only once in OBJ;
1156 that is, whose status is Qt.
1157 Maybe a better way to do that is to copy elements to
1158 a new hash table. */
1159 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vprint_number_table
);
1162 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
1163 if (!NILP (HASH_HASH (h
, i
))
1164 && EQ (HASH_VALUE (h
, i
), Qt
))
1165 Fremhash (HASH_KEY (h
, i
), Vprint_number_table
);
1170 print_object (obj
, printcharfun
, escapeflag
);
1173 #define PRINT_CIRCLE_CANDIDATE_P(obj) \
1174 (STRINGP (obj) || CONSP (obj) \
1175 || (VECTORLIKEP (obj) \
1176 && (VECTORP (obj) || COMPILEDP (obj) \
1177 || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \
1178 || HASH_TABLE_P (obj) || FONTP (obj))) \
1179 || (! NILP (Vprint_gensym) \
1181 && !SYMBOL_INTERNED_P (obj)))
1183 /* Construct Vprint_number_table according to the structure of OBJ.
1184 OBJ itself and all its elements will be added to Vprint_number_table
1185 recursively if it is a list, vector, compiled function, char-table,
1186 string (its text properties will be traced), or a symbol that has
1187 no obarray (this is for the print-gensym feature).
1188 The status fields of Vprint_number_table mean whether each object appears
1189 more than once in OBJ: Qnil at the first time, and Qt after that . */
1191 print_preprocess (Lisp_Object obj
)
1196 Lisp_Object halftail
;
1198 /* Give up if we go so deep that print_object will get an error. */
1199 /* See similar code in print_object. */
1200 if (print_depth
>= PRINT_CIRCLE
)
1201 error ("Apparently circular structure being printed");
1203 /* Avoid infinite recursion for circular nested structure
1204 in the case where Vprint_circle is nil. */
1205 if (NILP (Vprint_circle
))
1207 for (i
= 0; i
< print_depth
; i
++)
1208 if (EQ (obj
, being_printed
[i
]))
1210 being_printed
[print_depth
] = obj
;
1217 if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1219 if (!HASH_TABLE_P (Vprint_number_table
))
1221 Lisp_Object args
[2];
1224 Vprint_number_table
= Fmake_hash_table (2, args
);
1227 /* In case print-circle is nil and print-gensym is t,
1228 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1229 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1231 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1233 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1234 always print the gensym with a number. This is a special for
1235 the lisp function byte-compile-output-docform. */
1236 || (!NILP (Vprint_continuous_numbering
)
1238 && !SYMBOL_INTERNED_P (obj
)))
1239 { /* OBJ appears more than once. Let's remember that. */
1240 if (!INTEGERP (num
))
1242 print_number_index
++;
1243 /* Negative number indicates it hasn't been printed yet. */
1244 Fputhash (obj
, make_number (- print_number_index
),
1245 Vprint_number_table
);
1251 /* OBJ is not yet recorded. Let's add to the table. */
1252 Fputhash (obj
, Qt
, Vprint_number_table
);
1255 switch (XTYPE (obj
))
1258 /* A string may have text properties, which can be circular. */
1259 traverse_intervals_noorder (STRING_INTERVALS (obj
),
1260 print_preprocess_string
, Qnil
);
1264 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1265 just as in print_object. */
1266 if (loop_count
&& EQ (obj
, halftail
))
1268 print_preprocess (XCAR (obj
));
1271 if (!(loop_count
& 1))
1272 halftail
= XCDR (halftail
);
1275 case Lisp_Vectorlike
:
1276 size
= XVECTOR (obj
)->size
;
1277 if (size
& PSEUDOVECTOR_FLAG
)
1278 size
&= PSEUDOVECTOR_SIZE_MASK
;
1279 for (i
= 0; i
< size
; i
++)
1280 print_preprocess (XVECTOR (obj
)->contents
[i
]);
1281 if (HASH_TABLE_P (obj
))
1282 { /* For hash tables, the key_and_value slot is past
1283 `size' because it needs to be marked specially in case
1284 the table is weak. */
1285 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1286 print_preprocess (h
->key_and_value
);
1298 print_preprocess_string (INTERVAL interval
, Lisp_Object arg
)
1300 print_preprocess (interval
->plist
);
1303 static void print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
);
1305 #define PRINT_STRING_NON_CHARSET_FOUND 1
1306 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1308 /* Bitwise or of the above macros. */
1309 static int print_check_string_result
;
1312 print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
)
1316 if (NILP (interval
->plist
)
1317 || (print_check_string_result
== (PRINT_STRING_NON_CHARSET_FOUND
1318 | PRINT_STRING_UNSAFE_CHARSET_FOUND
)))
1320 for (val
= interval
->plist
; CONSP (val
) && ! EQ (XCAR (val
), Qcharset
);
1321 val
= XCDR (XCDR (val
)));
1324 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1327 if (! (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
))
1329 if (! EQ (val
, interval
->plist
)
1330 || CONSP (XCDR (XCDR (val
))))
1331 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1333 if (NILP (Vprint_charset_text_property
)
1334 || ! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1337 EMACS_INT charpos
= interval
->position
;
1338 EMACS_INT bytepos
= string_char_to_byte (string
, charpos
);
1339 Lisp_Object charset
;
1341 charset
= XCAR (XCDR (val
));
1342 for (i
= 0; i
< LENGTH (interval
); i
++)
1344 FETCH_STRING_CHAR_ADVANCE (c
, string
, charpos
, bytepos
);
1345 if (! ASCII_CHAR_P (c
)
1346 && ! EQ (CHARSET_NAME (CHAR_CHARSET (c
)), charset
))
1348 print_check_string_result
|= PRINT_STRING_UNSAFE_CHARSET_FOUND
;
1355 /* The value is (charset . nil). */
1356 static Lisp_Object print_prune_charset_plist
;
1359 print_prune_string_charset (Lisp_Object string
)
1361 print_check_string_result
= 0;
1362 traverse_intervals (STRING_INTERVALS (string
), 0,
1363 print_check_string_charset_prop
, string
);
1364 if (! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1366 string
= Fcopy_sequence (string
);
1367 if (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
)
1369 if (NILP (print_prune_charset_plist
))
1370 print_prune_charset_plist
= Fcons (Qcharset
, Qnil
);
1371 Fremove_text_properties (make_number (0),
1372 make_number (SCHARS (string
)),
1373 print_prune_charset_plist
, string
);
1376 Fset_text_properties (make_number (0), make_number (SCHARS (string
)),
1383 print_object (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
)
1389 /* See similar code in print_preprocess. */
1390 if (print_depth
>= PRINT_CIRCLE
)
1391 error ("Apparently circular structure being printed");
1393 /* Detect circularities and truncate them. */
1394 if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1396 if (NILP (Vprint_circle
) && NILP (Vprint_gensym
))
1398 /* Simple but incomplete way. */
1400 for (i
= 0; i
< print_depth
; i
++)
1401 if (EQ (obj
, being_printed
[i
]))
1403 sprintf (buf
, "#%d", i
);
1404 strout (buf
, -1, -1, printcharfun
);
1407 being_printed
[print_depth
] = obj
;
1411 /* With the print-circle feature. */
1412 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1417 { /* Add a prefix #n= if OBJ has not yet been printed;
1418 that is, its status field is nil. */
1419 sprintf (buf
, "#%d=", -n
);
1420 strout (buf
, -1, -1, printcharfun
);
1421 /* OBJ is going to be printed. Remember that fact. */
1422 Fputhash (obj
, make_number (- n
), Vprint_number_table
);
1426 /* Just print #n# if OBJ has already been printed. */
1427 sprintf (buf
, "#%d#", n
);
1428 strout (buf
, -1, -1, printcharfun
);
1437 switch (XTYPE (obj
))
1440 if (sizeof (int) == sizeof (EMACS_INT
))
1441 sprintf (buf
, "%d", (int) XINT (obj
));
1442 else if (sizeof (long) == sizeof (EMACS_INT
))
1443 sprintf (buf
, "%ld", (long) XINT (obj
));
1446 strout (buf
, -1, -1, printcharfun
);
1451 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
1453 float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1454 strout (pigbuf
, -1, -1, printcharfun
);
1460 print_string (obj
, printcharfun
);
1463 register EMACS_INT i
, i_byte
;
1464 struct gcpro gcpro1
;
1466 EMACS_INT size_byte
;
1467 /* 1 means we must ensure that the next character we output
1468 cannot be taken as part of a hex character escape. */
1469 int need_nonhex
= 0;
1470 int multibyte
= STRING_MULTIBYTE (obj
);
1474 if (! EQ (Vprint_charset_text_property
, Qt
))
1475 obj
= print_prune_string_charset (obj
);
1477 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1485 size_byte
= SBYTES (obj
);
1487 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1489 /* Here, we must convert each multi-byte form to the
1490 corresponding character code before handing it to PRINTCHAR. */
1496 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
, len
);
1504 if (c
== '\n' && print_escape_newlines
)
1509 else if (c
== '\f' && print_escape_newlines
)
1515 && (CHAR_BYTE8_P (c
)
1516 || (! ASCII_CHAR_P (c
) && print_escape_multibyte
)))
1518 /* When multibyte is disabled,
1519 print multibyte string chars using hex escapes.
1520 For a char code that could be in a unibyte string,
1521 when found in a multibyte string, always use a hex escape
1522 so it reads back as multibyte. */
1525 if (CHAR_BYTE8_P (c
))
1526 sprintf (outbuf
, "\\%03o", CHAR_TO_BYTE8 (c
));
1529 sprintf (outbuf
, "\\x%04x", c
);
1532 strout (outbuf
, -1, -1, printcharfun
);
1534 else if (! multibyte
1535 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1536 && print_escape_nonascii
)
1538 /* When printing in a multibyte buffer
1539 or when explicitly requested,
1540 print single-byte non-ASCII string chars
1541 using octal escapes. */
1543 sprintf (outbuf
, "\\%03o", c
);
1544 strout (outbuf
, -1, -1, printcharfun
);
1548 /* If we just had a hex escape, and this character
1549 could be taken as part of it,
1550 output `\ ' to prevent that. */
1554 if ((c
>= 'a' && c
<= 'f')
1555 || (c
>= 'A' && c
<= 'F')
1556 || (c
>= '0' && c
<= '9'))
1557 strout ("\\ ", -1, -1, printcharfun
);
1560 if (c
== '\"' || c
== '\\')
1567 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1569 traverse_intervals (STRING_INTERVALS (obj
),
1570 0, print_interval
, printcharfun
);
1580 register int confusing
;
1581 register unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1582 register unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1585 EMACS_INT size_byte
;
1588 name
= SYMBOL_NAME (obj
);
1590 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1593 /* If symbol name begins with a digit, and ends with a digit,
1594 and contains nothing but digits and `e', it could be treated
1595 as a number. So set CONFUSING.
1597 Symbols that contain periods could also be taken as numbers,
1598 but periods are always escaped, so we don't have to worry
1600 else if (*p
>= '0' && *p
<= '9'
1601 && end
[-1] >= '0' && end
[-1] <= '9')
1603 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1604 /* Needed for \2e10. */
1605 || *p
== 'e' || *p
== 'E'))
1607 confusing
= (end
== p
);
1612 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1618 size_byte
= SBYTES (name
);
1620 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1622 /* Here, we must convert each multi-byte form to the
1623 corresponding character code before handing it to PRINTCHAR. */
1624 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1629 if (c
== '\"' || c
== '\\' || c
== '\''
1630 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1631 || c
== ',' || c
=='.' || c
== '`'
1632 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1634 PRINTCHAR ('\\'), confusing
= 0;
1642 /* If deeper than spec'd depth, print placeholder. */
1643 if (INTEGERP (Vprint_level
)
1644 && print_depth
> XINT (Vprint_level
))
1645 strout ("...", -1, -1, printcharfun
);
1646 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1647 && (EQ (XCAR (obj
), Qquote
)))
1650 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1652 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1653 && (EQ (XCAR (obj
), Qfunction
)))
1657 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1659 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1660 && ((EQ (XCAR (obj
), Qbackquote
))))
1662 print_object (XCAR (obj
), printcharfun
, 0);
1663 new_backquote_output
++;
1664 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1665 new_backquote_output
--;
1667 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1668 && new_backquote_output
1669 && ((EQ (XCAR (obj
), Qbackquote
)
1670 || EQ (XCAR (obj
), Qcomma
)
1671 || EQ (XCAR (obj
), Qcomma_at
)
1672 || EQ (XCAR (obj
), Qcomma_dot
))))
1674 print_object (XCAR (obj
), printcharfun
, 0);
1675 new_backquote_output
--;
1676 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1677 new_backquote_output
++;
1684 EMACS_INT print_length
;
1686 Lisp_Object halftail
= obj
;
1688 /* Negative values of print-length are invalid in CL.
1689 Treat them like nil, as CMUCL does. */
1690 if (NATNUMP (Vprint_length
))
1691 print_length
= XFASTINT (Vprint_length
);
1698 /* Detect circular list. */
1699 if (NILP (Vprint_circle
))
1701 /* Simple but imcomplete way. */
1702 if (i
!= 0 && EQ (obj
, halftail
))
1704 sprintf (buf
, " . #%d", i
/ 2);
1705 strout (buf
, -1, -1, printcharfun
);
1711 /* With the print-circle feature. */
1714 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1717 strout (" . ", 3, 3, printcharfun
);
1718 print_object (obj
, printcharfun
, escapeflag
);
1727 if (print_length
&& i
> print_length
)
1729 strout ("...", 3, 3, printcharfun
);
1733 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1737 halftail
= XCDR (halftail
);
1741 /* OBJ non-nil here means it's the end of a dotted list. */
1744 strout (" . ", 3, 3, printcharfun
);
1745 print_object (obj
, printcharfun
, escapeflag
);
1753 case Lisp_Vectorlike
:
1758 strout ("#<process ", -1, -1, printcharfun
);
1759 print_string (XPROCESS (obj
)->name
, printcharfun
);
1763 print_string (XPROCESS (obj
)->name
, printcharfun
);
1765 else if (BOOL_VECTOR_P (obj
))
1768 register unsigned char c
;
1769 struct gcpro gcpro1
;
1770 EMACS_INT size_in_chars
1771 = ((XBOOL_VECTOR (obj
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
1772 / BOOL_VECTOR_BITS_PER_CHAR
);
1778 sprintf (buf
, "%ld", (long) XBOOL_VECTOR (obj
)->size
);
1779 strout (buf
, -1, -1, printcharfun
);
1782 /* Don't print more characters than the specified maximum.
1783 Negative values of print-length are invalid. Treat them
1784 like a print-length of nil. */
1785 if (NATNUMP (Vprint_length
)
1786 && XFASTINT (Vprint_length
) < size_in_chars
)
1787 size_in_chars
= XFASTINT (Vprint_length
);
1789 for (i
= 0; i
< size_in_chars
; i
++)
1792 c
= XBOOL_VECTOR (obj
)->data
[i
];
1793 if (c
== '\n' && print_escape_newlines
)
1798 else if (c
== '\f' && print_escape_newlines
)
1803 else if (c
> '\177')
1805 /* Use octal escapes to avoid encoding issues. */
1807 PRINTCHAR ('0' + ((c
>> 6) & 3));
1808 PRINTCHAR ('0' + ((c
>> 3) & 7));
1809 PRINTCHAR ('0' + (c
& 7));
1813 if (c
== '\"' || c
== '\\')
1822 else if (SUBRP (obj
))
1824 strout ("#<subr ", -1, -1, printcharfun
);
1825 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
);
1828 else if (WINDOWP (obj
))
1830 strout ("#<window ", -1, -1, printcharfun
);
1831 sprintf (buf
, "%ld", (long) XFASTINT (XWINDOW (obj
)->sequence_number
));
1832 strout (buf
, -1, -1, printcharfun
);
1833 if (!NILP (XWINDOW (obj
)->buffer
))
1835 strout (" on ", -1, -1, printcharfun
);
1836 print_string (BVAR (XBUFFER (XWINDOW (obj
)->buffer
), name
), printcharfun
);
1840 else if (TERMINALP (obj
))
1842 struct terminal
*t
= XTERMINAL (obj
);
1843 strout ("#<terminal ", -1, -1, printcharfun
);
1844 sprintf (buf
, "%d", t
->id
);
1845 strout (buf
, -1, -1, printcharfun
);
1848 strout (" on ", -1, -1, printcharfun
);
1849 strout (t
->name
, -1, -1, printcharfun
);
1853 else if (HASH_TABLE_P (obj
))
1855 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1857 EMACS_INT real_size
, size
;
1859 strout ("#<hash-table", -1, -1, printcharfun
);
1860 if (SYMBOLP (h
->test
))
1864 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
);
1866 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
);
1868 sprintf (buf
, "%ld/%ld", (long) h
->count
,
1869 (long) XVECTOR (h
->next
)->size
);
1870 strout (buf
, -1, -1, printcharfun
);
1872 sprintf (buf
, " 0x%lx", (unsigned long) h
);
1873 strout (buf
, -1, -1, printcharfun
);
1876 /* Implement a readable output, e.g.:
1877 #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
1878 /* Always print the size. */
1879 sprintf (buf
, "#s(hash-table size %ld",
1880 (long) XVECTOR (h
->next
)->size
);
1881 strout (buf
, -1, -1, printcharfun
);
1883 if (!NILP (h
->test
))
1885 strout (" test ", -1, -1, printcharfun
);
1886 print_object (h
->test
, printcharfun
, escapeflag
);
1889 if (!NILP (h
->weak
))
1891 strout (" weakness ", -1, -1, printcharfun
);
1892 print_object (h
->weak
, printcharfun
, escapeflag
);
1895 if (!NILP (h
->rehash_size
))
1897 strout (" rehash-size ", -1, -1, printcharfun
);
1898 print_object (h
->rehash_size
, printcharfun
, escapeflag
);
1901 if (!NILP (h
->rehash_threshold
))
1903 strout (" rehash-threshold ", -1, -1, printcharfun
);
1904 print_object (h
->rehash_threshold
, printcharfun
, escapeflag
);
1907 strout (" data ", -1, -1, printcharfun
);
1909 /* Print the data here as a plist. */
1910 real_size
= HASH_TABLE_SIZE (h
);
1913 /* Don't print more elements than the specified maximum. */
1914 if (NATNUMP (Vprint_length
)
1915 && XFASTINT (Vprint_length
) < size
)
1916 size
= XFASTINT (Vprint_length
);
1919 for (i
= 0; i
< size
; i
++)
1920 if (!NILP (HASH_HASH (h
, i
)))
1922 if (i
) PRINTCHAR (' ');
1923 print_object (HASH_KEY (h
, i
), printcharfun
, escapeflag
);
1925 print_object (HASH_VALUE (h
, i
), printcharfun
, escapeflag
);
1928 if (size
< real_size
)
1929 strout (" ...", 4, 4, printcharfun
);
1935 else if (BUFFERP (obj
))
1937 if (NILP (BVAR (XBUFFER (obj
), name
)))
1938 strout ("#<killed buffer>", -1, -1, printcharfun
);
1939 else if (escapeflag
)
1941 strout ("#<buffer ", -1, -1, printcharfun
);
1942 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1946 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1948 else if (WINDOW_CONFIGURATIONP (obj
))
1950 strout ("#<window-configuration>", -1, -1, printcharfun
);
1952 else if (FRAMEP (obj
))
1954 strout ((FRAME_LIVE_P (XFRAME (obj
))
1955 ? "#<frame " : "#<dead frame "),
1956 -1, -1, printcharfun
);
1957 print_string (XFRAME (obj
)->name
, printcharfun
);
1958 sprintf (buf
, " 0x%lx", (unsigned long) (XFRAME (obj
)));
1959 strout (buf
, -1, -1, printcharfun
);
1962 else if (FONTP (obj
))
1966 if (! FONT_OBJECT_P (obj
))
1968 if (FONT_SPEC_P (obj
))
1969 strout ("#<font-spec", -1, -1, printcharfun
);
1971 strout ("#<font-entity", -1, -1, printcharfun
);
1972 for (i
= 0; i
< FONT_SPEC_MAX
; i
++)
1975 if (i
< FONT_WEIGHT_INDEX
|| i
> FONT_WIDTH_INDEX
)
1976 print_object (AREF (obj
, i
), printcharfun
, escapeflag
);
1978 print_object (font_style_symbolic (obj
, i
, 0),
1979 printcharfun
, escapeflag
);
1984 strout ("#<font-object ", -1, -1, printcharfun
);
1985 print_object (AREF (obj
, FONT_NAME_INDEX
), printcharfun
,
1992 EMACS_INT size
= XVECTOR (obj
)->size
;
1993 if (COMPILEDP (obj
))
1996 size
&= PSEUDOVECTOR_SIZE_MASK
;
1998 if (CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
))
2000 /* We print a char-table as if it were a vector,
2001 lumping the parent and default slots in with the
2002 character slots. But we add #^ as a prefix. */
2004 /* Make each lowest sub_char_table start a new line.
2005 Otherwise we'll make a line extremely long, which
2006 results in slow redisplay. */
2007 if (SUB_CHAR_TABLE_P (obj
)
2008 && XINT (XSUB_CHAR_TABLE (obj
)->depth
) == 3)
2012 if (SUB_CHAR_TABLE_P (obj
))
2014 size
&= PSEUDOVECTOR_SIZE_MASK
;
2016 if (size
& PSEUDOVECTOR_FLAG
)
2022 register Lisp_Object tem
;
2023 EMACS_INT real_size
= size
;
2025 /* Don't print more elements than the specified maximum. */
2026 if (NATNUMP (Vprint_length
)
2027 && XFASTINT (Vprint_length
) < size
)
2028 size
= XFASTINT (Vprint_length
);
2030 for (i
= 0; i
< size
; i
++)
2032 if (i
) PRINTCHAR (' ');
2033 tem
= XVECTOR (obj
)->contents
[i
];
2034 print_object (tem
, printcharfun
, escapeflag
);
2036 if (size
< real_size
)
2037 strout (" ...", 4, 4, printcharfun
);
2044 switch (XMISCTYPE (obj
))
2046 case Lisp_Misc_Marker
:
2047 strout ("#<marker ", -1, -1, printcharfun
);
2048 /* Do you think this is necessary? */
2049 if (XMARKER (obj
)->insertion_type
!= 0)
2050 strout ("(moves after insertion) ", -1, -1, printcharfun
);
2051 if (! XMARKER (obj
)->buffer
)
2052 strout ("in no buffer", -1, -1, printcharfun
);
2055 sprintf (buf
, "at %ld", (long)marker_position (obj
));
2056 strout (buf
, -1, -1, printcharfun
);
2057 strout (" in ", -1, -1, printcharfun
);
2058 print_string (BVAR (XMARKER (obj
)->buffer
, name
), printcharfun
);
2063 case Lisp_Misc_Overlay
:
2064 strout ("#<overlay ", -1, -1, printcharfun
);
2065 if (! XMARKER (OVERLAY_START (obj
))->buffer
)
2066 strout ("in no buffer", -1, -1, printcharfun
);
2069 sprintf (buf
, "from %ld to %ld in ",
2070 (long)marker_position (OVERLAY_START (obj
)),
2071 (long)marker_position (OVERLAY_END (obj
)));
2072 strout (buf
, -1, -1, printcharfun
);
2073 print_string (BVAR (XMARKER (OVERLAY_START (obj
))->buffer
, name
),
2079 /* Remaining cases shouldn't happen in normal usage, but let's print
2080 them anyway for the benefit of the debugger. */
2081 case Lisp_Misc_Free
:
2082 strout ("#<misc free cell>", -1, -1, printcharfun
);
2085 case Lisp_Misc_Save_Value
:
2086 strout ("#<save_value ", -1, -1, printcharfun
);
2087 sprintf(buf
, "ptr=0x%08lx int=%d",
2088 (unsigned long) XSAVE_VALUE (obj
)->pointer
,
2089 XSAVE_VALUE (obj
)->integer
);
2090 strout (buf
, -1, -1, printcharfun
);
2102 /* We're in trouble if this happens!
2103 Probably should just abort () */
2104 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
);
2106 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2107 else if (VECTORLIKEP (obj
))
2108 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
2110 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2111 strout (buf
, -1, -1, printcharfun
);
2112 strout (" Save your buffers immediately and please report this bug>",
2113 -1, -1, printcharfun
);
2121 /* Print a description of INTERVAL using PRINTCHARFUN.
2122 This is part of printing a string that has text properties. */
2125 print_interval (INTERVAL interval
, Lisp_Object printcharfun
)
2127 if (NILP (interval
->plist
))
2130 print_object (make_number (interval
->position
), printcharfun
, 1);
2132 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2135 print_object (interval
->plist
, printcharfun
, 1);
2140 syms_of_print (void)
2142 Qtemp_buffer_setup_hook
= intern_c_string ("temp-buffer-setup-hook");
2143 staticpro (&Qtemp_buffer_setup_hook
);
2145 DEFVAR_LISP ("standard-output", Vstandard_output
,
2146 doc
: /* Output stream `print' uses by default for outputting a character.
2147 This may be any function of one argument.
2148 It may also be a buffer (output is inserted before point)
2149 or a marker (output is inserted and the marker is advanced)
2150 or the symbol t (output appears in the echo area). */);
2151 Vstandard_output
= Qt
;
2152 Qstandard_output
= intern_c_string ("standard-output");
2153 staticpro (&Qstandard_output
);
2155 DEFVAR_LISP ("float-output-format", Vfloat_output_format
,
2156 doc
: /* The format descriptor string used to print floats.
2157 This is a %-spec like those accepted by `printf' in C,
2158 but with some restrictions. It must start with the two characters `%.'.
2159 After that comes an integer precision specification,
2160 and then a letter which controls the format.
2161 The letters allowed are `e', `f' and `g'.
2162 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2163 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2164 Use `g' to choose the shorter of those two formats for the number at hand.
2165 The precision in any of these cases is the number of digits following
2166 the decimal point. With `f', a precision of 0 means to omit the
2167 decimal point. 0 is not allowed with `e' or `g'.
2169 A value of nil means to use the shortest notation
2170 that represents the number without losing information. */);
2171 Vfloat_output_format
= Qnil
;
2172 Qfloat_output_format
= intern_c_string ("float-output-format");
2173 staticpro (&Qfloat_output_format
);
2175 DEFVAR_LISP ("print-length", Vprint_length
,
2176 doc
: /* Maximum length of list to print before abbreviating.
2177 A value of nil means no limit. See also `eval-expression-print-length'. */);
2178 Vprint_length
= Qnil
;
2180 DEFVAR_LISP ("print-level", Vprint_level
,
2181 doc
: /* Maximum depth of list nesting to print before abbreviating.
2182 A value of nil means no limit. See also `eval-expression-print-level'. */);
2183 Vprint_level
= Qnil
;
2185 DEFVAR_BOOL ("print-escape-newlines", print_escape_newlines
,
2186 doc
: /* Non-nil means print newlines in strings as `\\n'.
2187 Also print formfeeds as `\\f'. */);
2188 print_escape_newlines
= 0;
2190 DEFVAR_BOOL ("print-escape-nonascii", print_escape_nonascii
,
2191 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2192 \(OOO is the octal representation of the character code.)
2193 Only single-byte characters are affected, and only in `prin1'.
2194 When the output goes in a multibyte buffer, this feature is
2195 enabled regardless of the value of the variable. */);
2196 print_escape_nonascii
= 0;
2198 DEFVAR_BOOL ("print-escape-multibyte", print_escape_multibyte
,
2199 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2200 \(XXXX is the hex representation of the character code.)
2201 This affects only `prin1'. */);
2202 print_escape_multibyte
= 0;
2204 DEFVAR_BOOL ("print-quoted", print_quoted
,
2205 doc
: /* Non-nil means print quoted forms with reader syntax.
2206 I.e., (quote foo) prints as 'foo, (function foo) as #'foo. */);
2209 DEFVAR_LISP ("print-gensym", Vprint_gensym
,
2210 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2211 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2212 When the uninterned symbol appears within a recursive data structure,
2213 and the symbol appears more than once, in addition use the #N# and #N=
2214 constructs as needed, so that multiple references to the same symbol are
2215 shared once again when the text is read back. */);
2216 Vprint_gensym
= Qnil
;
2218 DEFVAR_LISP ("print-circle", Vprint_circle
,
2219 doc
: /* *Non-nil means print recursive structures using #N= and #N# syntax.
2220 If nil, printing proceeds recursively and may lead to
2221 `max-lisp-eval-depth' being exceeded or an error may occur:
2222 \"Apparently circular structure being printed.\" Also see
2223 `print-length' and `print-level'.
2224 If non-nil, shared substructures anywhere in the structure are printed
2225 with `#N=' before the first occurrence (in the order of the print
2226 representation) and `#N#' in place of each subsequent occurrence,
2227 where N is a positive decimal integer. */);
2228 Vprint_circle
= Qnil
;
2230 DEFVAR_LISP ("print-continuous-numbering", Vprint_continuous_numbering
,
2231 doc
: /* *Non-nil means number continuously across print calls.
2232 This affects the numbers printed for #N= labels and #M# references.
2233 See also `print-circle', `print-gensym', and `print-number-table'.
2234 This variable should not be set with `setq'; bind it with a `let' instead. */);
2235 Vprint_continuous_numbering
= Qnil
;
2237 DEFVAR_LISP ("print-number-table", Vprint_number_table
,
2238 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2239 The Lisp printer uses this vector to detect Lisp objects referenced more
2242 When you bind `print-continuous-numbering' to t, you should probably
2243 also bind `print-number-table' to nil. This ensures that the value of
2244 `print-number-table' can be garbage-collected once the printing is
2245 done. If all elements of `print-number-table' are nil, it means that
2246 the printing done so far has not found any shared structure or objects
2247 that need to be recorded in the table. */);
2248 Vprint_number_table
= Qnil
;
2250 DEFVAR_LISP ("print-charset-text-property", Vprint_charset_text_property
,
2251 doc
: /* A flag to control printing of `charset' text property on printing a string.
2252 The value must be nil, t, or `default'.
2254 If the value is nil, don't print the text property `charset'.
2256 If the value is t, always print the text property `charset'.
2258 If the value is `default', print the text property `charset' only when
2259 the value is different from what is guessed in the current charset
2261 Vprint_charset_text_property
= Qdefault
;
2263 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2264 staticpro (&Vprin1_to_string_buffer
);
2267 defsubr (&Sprin1_to_string
);
2268 defsubr (&Serror_message_string
);
2272 defsubr (&Swrite_char
);
2273 defsubr (&Sexternal_debugging_output
);
2274 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2275 defsubr (&Sredirect_debugging_output
);
2278 Qexternal_debugging_output
= intern_c_string ("external-debugging-output");
2279 staticpro (&Qexternal_debugging_output
);
2281 Qprint_escape_newlines
= intern_c_string ("print-escape-newlines");
2282 staticpro (&Qprint_escape_newlines
);
2284 Qprint_escape_multibyte
= intern_c_string ("print-escape-multibyte");
2285 staticpro (&Qprint_escape_multibyte
);
2287 Qprint_escape_nonascii
= intern_c_string ("print-escape-nonascii");
2288 staticpro (&Qprint_escape_nonascii
);
2290 print_prune_charset_plist
= Qnil
;
2291 staticpro (&print_prune_charset_plist
);
2293 defsubr (&Swith_output_to_temp_buffer
);