1 /* Lisp object printing and output streams.
2 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2011 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software: you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation, either version 3 of the License, or
9 (at your option) any later version.
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
25 #include "character.h"
31 #include "dispextern.h"
33 #include "intervals.h"
34 #include "blockinput.h"
35 #include "termhooks.h" /* For struct terminal. */
38 Lisp_Object Qstandard_output
;
40 Lisp_Object Qtemp_buffer_setup_hook
;
42 /* These are used to print like we read. */
44 Lisp_Object Qfloat_output_format
;
53 /* Default to values appropriate for IEEE floating point. */
58 /* Avoid actual stack overflow in print. */
61 /* Level of nesting inside outputting backquote in new style. */
62 int new_backquote_output
;
64 /* Detect most circularities to print finite output. */
65 #define PRINT_CIRCLE 200
66 Lisp_Object being_printed
[PRINT_CIRCLE
];
68 /* When printing into a buffer, first we put the text in this
69 block, then insert it all at once. */
72 /* Size allocated in print_buffer. */
73 EMACS_INT print_buffer_size
;
74 /* Chars stored in print_buffer. */
75 EMACS_INT print_buffer_pos
;
76 /* Bytes stored in print_buffer. */
77 EMACS_INT print_buffer_pos_byte
;
79 Lisp_Object Qprint_escape_newlines
;
80 Lisp_Object Qprint_escape_multibyte
, Qprint_escape_nonascii
;
82 /* Vprint_number_table is a table, that keeps objects that are going to
83 be printed, to allow use of #n= and #n# to express sharing.
84 For any given object, the table can give the following values:
85 t the object will be printed only once.
86 -N the object will be printed several times and will take number N.
87 N the object has been printed so we can refer to it as #N#.
88 print_number_index holds the largest N already used.
89 N has to be striclty larger than 0 since we need to distinguish -N. */
90 int print_number_index
;
91 void print_interval (INTERVAL interval
, Lisp_Object printcharfun
);
93 /* GDB resets this to zero on W32 to disable OutputDebugString calls. */
94 int print_output_debug_flag EXTERNALLY_VISIBLE
= 1;
97 /* Low level output routines for characters and strings */
99 /* Lisp functions to do output using a stream
100 must have the stream in a variable called printcharfun
101 and must start with PRINTPREPARE, end with PRINTFINISH,
102 and use PRINTDECLARE to declare common variables.
103 Use PRINTCHAR to output one character,
104 or call strout to output a block of characters. */
106 #define PRINTDECLARE \
107 struct buffer *old = current_buffer; \
108 EMACS_INT old_point = -1, start_point = -1; \
109 EMACS_INT old_point_byte = -1, start_point_byte = -1; \
110 int specpdl_count = SPECPDL_INDEX (); \
111 int free_print_buffer = 0; \
112 int multibyte = !NILP (current_buffer->enable_multibyte_characters); \
115 #define PRINTPREPARE \
116 original = printcharfun; \
117 if (NILP (printcharfun)) printcharfun = Qt; \
118 if (BUFFERP (printcharfun)) \
120 if (XBUFFER (printcharfun) != current_buffer) \
121 Fset_buffer (printcharfun); \
122 printcharfun = Qnil; \
124 if (MARKERP (printcharfun)) \
126 EMACS_INT marker_pos; \
127 if (! XMARKER (printcharfun)->buffer) \
128 error ("Marker does not point anywhere"); \
129 if (XMARKER (printcharfun)->buffer != current_buffer) \
130 set_buffer_internal (XMARKER (printcharfun)->buffer); \
131 marker_pos = marker_position (printcharfun); \
132 if (marker_pos < BEGV || marker_pos > ZV) \
133 error ("Marker is outside the accessible part of the buffer"); \
135 old_point_byte = PT_BYTE; \
136 SET_PT_BOTH (marker_pos, \
137 marker_byte_position (printcharfun)); \
139 start_point_byte = PT_BYTE; \
140 printcharfun = Qnil; \
142 if (NILP (printcharfun)) \
144 Lisp_Object string; \
145 if (NILP (current_buffer->enable_multibyte_characters) \
146 && ! print_escape_multibyte) \
147 specbind (Qprint_escape_multibyte, Qt); \
148 if (! NILP (current_buffer->enable_multibyte_characters) \
149 && ! print_escape_nonascii) \
150 specbind (Qprint_escape_nonascii, Qt); \
151 if (print_buffer != 0) \
153 string = make_string_from_bytes (print_buffer, \
155 print_buffer_pos_byte); \
156 record_unwind_protect (print_unwind, string); \
160 print_buffer_size = 1000; \
161 print_buffer = (char *) xmalloc (print_buffer_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 (current_buffer->enable_multibyte_characters)) \
176 unsigned char *temp \
177 = (unsigned char *) alloca (print_buffer_pos + 1); \
178 copy_text (print_buffer, temp, print_buffer_pos_byte, \
180 insert_1_both (temp, print_buffer_pos, \
181 print_buffer_pos, 0, 1, 0); \
184 insert_1_both (print_buffer, print_buffer_pos, \
185 print_buffer_pos_byte, 0, 1, 0); \
186 signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
188 if (free_print_buffer) \
190 xfree (print_buffer); \
193 unbind_to (specpdl_count, Qnil); \
194 if (MARKERP (original)) \
195 set_marker_both (original, Qnil, PT, PT_BYTE); \
196 if (old_point >= 0) \
197 SET_PT_BOTH (old_point + (old_point >= start_point \
198 ? PT - start_point : 0), \
199 old_point_byte + (old_point_byte >= start_point_byte \
200 ? PT_BYTE - start_point_byte : 0)); \
201 if (old != current_buffer) \
202 set_buffer_internal (old);
204 #define PRINTCHAR(ch) printchar (ch, printcharfun)
206 /* This is used to restore the saved contents of print_buffer
207 when there is a recursive call to print. */
210 print_unwind (Lisp_Object saved_text
)
212 memcpy (print_buffer
, SDATA (saved_text
), SCHARS (saved_text
));
217 /* Print character CH using method FUN. FUN nil means print to
218 print_buffer. FUN t means print to echo area or stdout if
219 non-interactive. If FUN is neither nil nor t, call FUN with CH as
223 printchar (unsigned int ch
, Lisp_Object fun
)
225 if (!NILP (fun
) && !EQ (fun
, Qt
))
226 call1 (fun
, make_number (ch
));
229 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
230 int len
= CHAR_STRING (ch
, str
);
236 if (print_buffer_pos_byte
+ len
>= print_buffer_size
)
237 print_buffer
= (char *) xrealloc (print_buffer
,
238 print_buffer_size
*= 2);
239 memcpy (print_buffer
+ print_buffer_pos_byte
, str
, len
);
240 print_buffer_pos
+= 1;
241 print_buffer_pos_byte
+= len
;
243 else if (noninteractive
)
245 fwrite (str
, 1, len
, stdout
);
246 noninteractive_need_newline
= 1;
251 = !NILP (current_buffer
->enable_multibyte_characters
);
253 setup_echo_area_for_printing (multibyte_p
);
255 message_dolog (str
, len
, 0, multibyte_p
);
261 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
262 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
263 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
264 print_buffer. PRINTCHARFUN t means output to the echo area or to
265 stdout if non-interactive. If neither nil nor t, call Lisp
266 function PRINTCHARFUN for each character printed. MULTIBYTE
267 non-zero means PTR contains multibyte characters.
269 In the case where PRINTCHARFUN is nil, it is safe for PTR to point
270 to data in a Lisp string. Otherwise that is not safe. */
273 strout (const char *ptr
, EMACS_INT size
, EMACS_INT size_byte
,
274 Lisp_Object printcharfun
, int multibyte
)
277 size_byte
= size
= strlen (ptr
);
279 if (NILP (printcharfun
))
281 if (print_buffer_pos_byte
+ size_byte
> print_buffer_size
)
283 print_buffer_size
= print_buffer_size
* 2 + size_byte
;
284 print_buffer
= (char *) xrealloc (print_buffer
,
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 (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 (ptr
+ i
, len
);
325 /* PRINTCHARFUN is a Lisp function. */
328 if (size
== size_byte
)
330 while (i
< size_byte
)
338 while (i
< size_byte
)
340 /* Here, we must convert each multi-byte form to the
341 corresponding character code before handing it to
344 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, len
);
352 /* Print the contents of a string STRING using PRINTCHARFUN.
353 It isn't safe to use strout in many cases,
354 because printing one char can relocate. */
357 print_string (Lisp_Object string
, Lisp_Object printcharfun
)
359 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
363 if (print_escape_nonascii
)
364 string
= string_escape_byte8 (string
);
366 if (STRING_MULTIBYTE (string
))
367 chars
= SCHARS (string
);
368 else if (! print_escape_nonascii
369 && (EQ (printcharfun
, Qt
)
370 ? ! NILP (buffer_defaults
.enable_multibyte_characters
)
371 : ! NILP (current_buffer
->enable_multibyte_characters
)))
373 /* If unibyte string STRING contains 8-bit codes, we must
374 convert STRING to a multibyte string containing the same
379 chars
= SBYTES (string
);
380 bytes
= parse_str_to_multibyte (SDATA (string
), chars
);
383 newstr
= make_uninit_multibyte_string (chars
, bytes
);
384 memcpy (SDATA (newstr
), SDATA (string
), chars
);
385 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
390 chars
= SBYTES (string
);
392 if (EQ (printcharfun
, Qt
))
394 /* Output to echo area. */
395 EMACS_INT nbytes
= SBYTES (string
);
398 /* Copy the string contents so that relocation of STRING by
399 GC does not cause trouble. */
402 SAFE_ALLOCA (buffer
, char *, nbytes
);
403 memcpy (buffer
, SDATA (string
), nbytes
);
405 strout (buffer
, chars
, SBYTES (string
),
406 printcharfun
, STRING_MULTIBYTE (string
));
411 /* No need to copy, since output to print_buffer can't GC. */
412 strout (SDATA (string
),
413 chars
, SBYTES (string
),
414 printcharfun
, STRING_MULTIBYTE (string
));
418 /* Otherwise, string may be relocated by printing one char.
419 So re-fetch the string address for each character. */
421 EMACS_INT size
= SCHARS (string
);
422 EMACS_INT size_byte
= SBYTES (string
);
425 if (size
== size_byte
)
426 for (i
= 0; i
< size
; i
++)
427 PRINTCHAR (SREF (string
, i
));
429 for (i
= 0; i
< size_byte
; )
431 /* Here, we must convert each multi-byte form to the
432 corresponding character code before handing it to PRINTCHAR. */
434 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
, len
);
442 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
443 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
444 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
445 (Lisp_Object character
, Lisp_Object printcharfun
)
449 if (NILP (printcharfun
))
450 printcharfun
= Vstandard_output
;
451 CHECK_NUMBER (character
);
453 PRINTCHAR (XINT (character
));
458 /* Used from outside of print.c to print a block of SIZE
459 single-byte chars at DATA on the default output stream.
460 Do not use this on the contents of a Lisp string. */
463 write_string (const char *data
, int size
)
466 Lisp_Object printcharfun
;
468 printcharfun
= Vstandard_output
;
471 strout (data
, size
, size
, printcharfun
, 0);
475 /* Used to print a block of SIZE single-byte chars at DATA on a
476 specified stream PRINTCHARFUN.
477 Do not use this on the contents of a Lisp string. */
480 write_string_1 (const char *data
, int size
, Lisp_Object printcharfun
)
485 strout (data
, size
, size
, printcharfun
, 0);
491 temp_output_buffer_setup (const char *bufname
)
493 int count
= SPECPDL_INDEX ();
494 register struct buffer
*old
= current_buffer
;
495 register Lisp_Object buf
;
497 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
499 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
501 Fkill_all_local_variables ();
502 delete_all_overlays (current_buffer
);
503 current_buffer
->directory
= old
->directory
;
504 current_buffer
->read_only
= Qnil
;
505 current_buffer
->filename
= Qnil
;
506 current_buffer
->undo_list
= Qt
;
507 eassert (current_buffer
->overlays_before
== NULL
);
508 eassert (current_buffer
->overlays_after
== NULL
);
509 current_buffer
->enable_multibyte_characters
510 = buffer_defaults
.enable_multibyte_characters
;
511 specbind (Qinhibit_read_only
, Qt
);
512 specbind (Qinhibit_modification_hooks
, Qt
);
514 XSETBUFFER (buf
, current_buffer
);
516 Frun_hooks (1, &Qtemp_buffer_setup_hook
);
518 unbind_to (count
, Qnil
);
520 specbind (Qstandard_output
, buf
);
524 internal_with_output_to_temp_buffer (const char *bufname
, Lisp_Object (*function
) (Lisp_Object
), Lisp_Object args
)
526 int count
= SPECPDL_INDEX ();
527 Lisp_Object buf
, val
;
531 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
532 temp_output_buffer_setup (bufname
);
533 buf
= Vstandard_output
;
536 val
= (*function
) (args
);
539 temp_output_buffer_show (buf
);
542 return unbind_to (count
, val
);
545 DEFUN ("with-output-to-temp-buffer",
546 Fwith_output_to_temp_buffer
, Swith_output_to_temp_buffer
,
548 doc
: /* Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
550 This construct makes buffer BUFNAME empty before running BODY.
551 It does not make the buffer current for BODY.
552 Instead it binds `standard-output' to that buffer, so that output
553 generated with `prin1' and similar functions in BODY goes into
556 At the end of BODY, this marks buffer BUFNAME unmodifed and displays
557 it in a window, but does not select it. The normal way to do this is
558 by calling `display-buffer', then running `temp-buffer-show-hook'.
559 However, if `temp-buffer-show-function' is non-nil, it calls that
560 function instead (and does not run `temp-buffer-show-hook'). The
561 function gets one argument, the buffer to display.
563 The return value of `with-output-to-temp-buffer' is the value of the
564 last form in BODY. If BODY does not finish normally, the buffer
565 BUFNAME is not displayed.
567 This runs the hook `temp-buffer-setup-hook' before BODY,
568 with the buffer BUFNAME temporarily current. It runs the hook
569 `temp-buffer-show-hook' after displaying buffer BUFNAME, with that
570 buffer temporarily current, and the window that was used to display it
571 temporarily selected. But it doesn't run `temp-buffer-show-hook'
572 if it uses `temp-buffer-show-function'.
574 usage: (with-output-to-temp-buffer BUFNAME BODY...) */)
579 int count
= SPECPDL_INDEX ();
580 Lisp_Object buf
, val
;
583 name
= Feval (Fcar (args
));
585 temp_output_buffer_setup (SDATA (name
));
586 buf
= Vstandard_output
;
589 val
= Fprogn (XCDR (args
));
592 temp_output_buffer_show (buf
);
595 return unbind_to (count
, val
);
599 static void print (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
);
600 static void print_preprocess (Lisp_Object obj
);
601 static void print_preprocess_string (INTERVAL interval
, Lisp_Object arg
);
602 static void print_object (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
);
604 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
605 doc
: /* Output a newline to stream PRINTCHARFUN.
606 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
607 (Lisp_Object printcharfun
)
611 if (NILP (printcharfun
))
612 printcharfun
= Vstandard_output
;
619 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
620 doc
: /* Output the printed representation of OBJECT, any Lisp object.
621 Quoting characters are printed when needed to make output that `read'
622 can handle, whenever this is possible. For complex objects, the behavior
623 is controlled by `print-level' and `print-length', which see.
625 OBJECT is any of the Lisp data types: a number, a string, a symbol,
626 a list, a buffer, a window, a frame, etc.
628 A printed representation of an object is text which describes that object.
630 Optional argument PRINTCHARFUN is the output stream, which can be one
633 - a buffer, in which case output is inserted into that buffer at point;
634 - a marker, in which case output is inserted at marker's position;
635 - a function, in which case that function is called once for each
636 character of OBJECT's printed representation;
637 - a symbol, in which case that symbol's function definition is called; or
638 - t, in which case the output is displayed in the echo area.
640 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
642 (Lisp_Object object
, Lisp_Object printcharfun
)
646 if (NILP (printcharfun
))
647 printcharfun
= Vstandard_output
;
649 print (object
, printcharfun
, 1);
654 /* a buffer which is used to hold output being built by prin1-to-string */
655 Lisp_Object Vprin1_to_string_buffer
;
657 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
658 doc
: /* Return a string containing the printed representation of OBJECT.
659 OBJECT can be any Lisp object. This function outputs quoting characters
660 when necessary to make output that `read' can handle, whenever possible,
661 unless the optional second argument NOESCAPE is non-nil. For complex objects,
662 the behavior is controlled by `print-level' and `print-length', which see.
664 OBJECT is any of the Lisp data types: a number, a string, a symbol,
665 a list, a buffer, a window, a frame, etc.
667 A printed representation of an object is text which describes that object. */)
668 (Lisp_Object object
, Lisp_Object noescape
)
670 Lisp_Object printcharfun
;
671 /* struct gcpro gcpro1, gcpro2; */
672 Lisp_Object save_deactivate_mark
;
673 int count
= SPECPDL_INDEX ();
674 struct buffer
*previous
;
676 specbind (Qinhibit_modification_hooks
, Qt
);
681 /* Save and restore this--we are altering a buffer
682 but we don't want to deactivate the mark just for that.
683 No need for specbind, since errors deactivate the mark. */
684 save_deactivate_mark
= Vdeactivate_mark
;
685 /* GCPRO2 (object, save_deactivate_mark); */
688 printcharfun
= Vprin1_to_string_buffer
;
690 print (object
, printcharfun
, NILP (noescape
));
691 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
695 previous
= current_buffer
;
696 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
697 object
= Fbuffer_string ();
698 if (SBYTES (object
) == SCHARS (object
))
699 STRING_SET_UNIBYTE (object
);
701 /* Note that this won't make prepare_to_modify_buffer call
702 ask-user-about-supersession-threat because this buffer
703 does not visit a file. */
705 set_buffer_internal (previous
);
707 Vdeactivate_mark
= save_deactivate_mark
;
711 return unbind_to (count
, object
);
714 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
715 doc
: /* Output the printed representation of OBJECT, any Lisp object.
716 No quoting characters are used; no delimiters are printed around
717 the contents of strings.
719 OBJECT is any of the Lisp data types: a number, a string, a symbol,
720 a list, a buffer, a window, a frame, etc.
722 A printed representation of an object is text which describes that object.
724 Optional argument PRINTCHARFUN is the output stream, which can be one
727 - a buffer, in which case output is inserted into that buffer at point;
728 - a marker, in which case output is inserted at marker's position;
729 - a function, in which case that function is called once for each
730 character of OBJECT's printed representation;
731 - a symbol, in which case that symbol's function definition is called; or
732 - t, in which case the output is displayed in the echo area.
734 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
736 (Lisp_Object object
, Lisp_Object printcharfun
)
740 if (NILP (printcharfun
))
741 printcharfun
= Vstandard_output
;
743 print (object
, printcharfun
, 0);
748 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
749 doc
: /* Output the printed representation of OBJECT, with newlines around it.
750 Quoting characters are printed when needed to make output that `read'
751 can handle, whenever this is possible. For complex objects, the behavior
752 is controlled by `print-level' and `print-length', which see.
754 OBJECT is any of the Lisp data types: a number, a string, a symbol,
755 a list, a buffer, a window, a frame, etc.
757 A printed representation of an object is text which describes that object.
759 Optional argument PRINTCHARFUN is the output stream, which can be one
762 - a buffer, in which case output is inserted into that buffer at point;
763 - a marker, in which case output is inserted at marker's position;
764 - a function, in which case that function is called once for each
765 character of OBJECT's printed representation;
766 - a symbol, in which case that symbol's function definition is called; or
767 - t, in which case the output is displayed in the echo area.
769 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
771 (Lisp_Object object
, Lisp_Object printcharfun
)
776 if (NILP (printcharfun
))
777 printcharfun
= Vstandard_output
;
781 print (object
, printcharfun
, 1);
788 /* The subroutine object for external-debugging-output is kept here
789 for the convenience of the debugger. */
790 Lisp_Object Qexternal_debugging_output
;
792 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
793 doc
: /* Write CHARACTER to stderr.
794 You can call print while debugging emacs, and pass it this function
795 to make it write to the debugging output. */)
796 (Lisp_Object character
)
798 CHECK_NUMBER (character
);
799 putc ((int) XINT (character
), stderr
);
802 /* Send the output to a debugger (nothing happens if there isn't one). */
803 if (print_output_debug_flag
)
805 char buf
[2] = {(char) XINT (character
), '\0'};
806 OutputDebugString (buf
);
813 /* This function is never called. Its purpose is to prevent
814 print_output_debug_flag from being optimized away. */
817 debug_output_compilation_hack (int x
)
819 print_output_debug_flag
= x
;
822 #if defined (GNU_LINUX)
824 /* This functionality is not vitally important in general, so we rely on
825 non-portable ability to use stderr as lvalue. */
827 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
829 FILE *initial_stderr_stream
= NULL
;
831 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
833 "FDebug output file: \nP",
834 doc
: /* Redirect debugging output (stderr stream) to file FILE.
835 If FILE is nil, reset target to the initial stderr stream.
836 Optional arg APPEND non-nil (interactively, with prefix arg) means
837 append to existing target file. */)
838 (Lisp_Object file
, Lisp_Object append
)
840 if (initial_stderr_stream
!= NULL
)
846 stderr
= initial_stderr_stream
;
847 initial_stderr_stream
= NULL
;
851 file
= Fexpand_file_name (file
, Qnil
);
852 initial_stderr_stream
= stderr
;
853 stderr
= fopen (SDATA (file
), NILP (append
) ? "w" : "a");
856 stderr
= initial_stderr_stream
;
857 initial_stderr_stream
= NULL
;
858 report_file_error ("Cannot open debugging output stream",
864 #endif /* GNU_LINUX */
867 /* This is the interface for debugging printing. */
870 debug_print (Lisp_Object arg
)
872 Fprin1 (arg
, Qexternal_debugging_output
);
873 fprintf (stderr
, "\r\n");
877 safe_debug_print (Lisp_Object arg
)
879 int valid
= valid_lisp_object_p (arg
);
884 fprintf (stderr
, "#<%s_LISP_OBJECT 0x%08lx>\r\n",
885 !valid
? "INVALID" : "SOME",
886 (unsigned long) XHASH (arg
)
891 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
893 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
894 See Info anchor `(elisp)Definition of signal' for some details on how this
895 error message is constructed. */)
898 struct buffer
*old
= current_buffer
;
902 /* If OBJ is (error STRING), just return STRING.
903 That is not only faster, it also avoids the need to allocate
904 space here when the error is due to memory full. */
905 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
906 && CONSP (XCDR (obj
))
907 && STRINGP (XCAR (XCDR (obj
)))
908 && NILP (XCDR (XCDR (obj
))))
909 return XCAR (XCDR (obj
));
911 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
913 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
914 value
= Fbuffer_string ();
918 set_buffer_internal (old
);
924 /* Print an error message for the error DATA onto Lisp output stream
925 STREAM (suitable for the print functions).
926 CONTEXT is a C string describing the context of the error.
927 CALLER is the Lisp function inside which the error was signaled. */
930 print_error_message (Lisp_Object data
, Lisp_Object stream
, const char *context
,
933 Lisp_Object errname
, errmsg
, file_error
, tail
;
938 write_string_1 (context
, -1, stream
);
940 /* If we know from where the error was signaled, show it in
942 if (!NILP (caller
) && SYMBOLP (caller
))
944 Lisp_Object cname
= SYMBOL_NAME (caller
);
945 char *name
= alloca (SBYTES (cname
));
946 memcpy (name
, SDATA (cname
), SBYTES (cname
));
947 message_dolog (name
, SBYTES (cname
), 0, 0);
948 message_dolog (": ", 2, 0, 0);
951 errname
= Fcar (data
);
953 if (EQ (errname
, Qerror
))
958 errmsg
= Fcar (data
);
963 Lisp_Object error_conditions
;
964 errmsg
= Fget (errname
, Qerror_message
);
965 error_conditions
= Fget (errname
, Qerror_conditions
);
966 file_error
= Fmemq (Qfile_error
, error_conditions
);
969 /* Print an error message including the data items. */
971 tail
= Fcdr_safe (data
);
974 /* For file-error, make error message by concatenating
975 all the data items. They are all strings. */
976 if (!NILP (file_error
) && CONSP (tail
))
977 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
979 if (STRINGP (errmsg
))
980 Fprinc (errmsg
, stream
);
982 write_string_1 ("peculiar error", -1, stream
);
984 for (i
= 0; CONSP (tail
); tail
= XCDR (tail
), i
++)
988 write_string_1 (i
? ", " : ": ", 2, stream
);
990 if (!NILP (file_error
) || EQ (errname
, Qend_of_file
))
991 Fprinc (obj
, stream
);
993 Fprin1 (obj
, stream
);
1002 * The buffer should be at least as large as the max string size of the
1003 * largest float, printed in the biggest notation. This is undoubtedly
1004 * 20d float_output_format, with the negative of the C-constant "HUGE"
1007 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
1009 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
1010 * case of -1e307 in 20d float_output_format. What is one to do (short of
1011 * re-writing _doprnt to be more sane)?
1013 * Given the above, the buffer must be least FLOAT_TO_STRING_BUFSIZE bytes.
1017 float_to_string (unsigned char *buf
, double data
)
1022 /* Check for plus infinity in a way that won't lose
1023 if there is no plus infinity. */
1024 if (data
== data
/ 2 && data
> 1.0)
1026 strcpy (buf
, "1.0e+INF");
1029 /* Likewise for minus infinity. */
1030 if (data
== data
/ 2 && data
< -1.0)
1032 strcpy (buf
, "-1.0e+INF");
1035 /* Check for NaN in a way that won't fail if there are no NaNs. */
1036 if (! (data
* 0.0 >= 0.0))
1038 /* Prepend "-" if the NaN's sign bit is negative.
1039 The sign bit of a double is the bit that is 1 in -0.0. */
1041 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
1043 u_minus_zero
.d
= - 0.0;
1044 for (i
= 0; i
< sizeof (double); i
++)
1045 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
1051 strcpy (buf
, "0.0e+NaN");
1055 if (NILP (Vfloat_output_format
)
1056 || !STRINGP (Vfloat_output_format
))
1059 /* Generate the fewest number of digits that represent the
1060 floating point value without losing information. */
1061 dtoastr (buf
, FLOAT_TO_STRING_BUFSIZE
, 0, 0, data
);
1063 else /* oink oink */
1065 /* Check that the spec we have is fully valid.
1066 This means not only valid for printf,
1067 but meant for floats, and reasonable. */
1068 cp
= SDATA (Vfloat_output_format
);
1077 /* Check the width specification. */
1079 if ('0' <= *cp
&& *cp
<= '9')
1083 width
= (width
* 10) + (*cp
++ - '0');
1084 while (*cp
>= '0' && *cp
<= '9');
1086 /* A precision of zero is valid only for %f. */
1088 || (width
== 0 && *cp
!= 'f'))
1092 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1098 sprintf (buf
, SDATA (Vfloat_output_format
), data
);
1101 /* Make sure there is a decimal point with digit after, or an
1102 exponent, so that the value is readable as a float. But don't do
1103 this with "%.0f"; it's valid for that not to produce a decimal
1104 point. Note that width can be 0 only for %.0f. */
1107 for (cp
= buf
; *cp
; cp
++)
1108 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1111 if (*cp
== '.' && cp
[1] == 0)
1128 print (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
)
1130 new_backquote_output
= 0;
1132 /* Reset print_number_index and Vprint_number_table only when
1133 the variable Vprint_continuous_numbering is nil. Otherwise,
1134 the values of these variables will be kept between several
1136 if (NILP (Vprint_continuous_numbering
)
1137 || NILP (Vprint_number_table
))
1139 print_number_index
= 0;
1140 Vprint_number_table
= Qnil
;
1143 /* Construct Vprint_number_table for print-gensym and print-circle. */
1144 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1146 /* Construct Vprint_number_table.
1147 This increments print_number_index for the objects added. */
1149 print_preprocess (obj
);
1151 if (HASH_TABLE_P (Vprint_number_table
))
1152 { /* Remove unnecessary objects, which appear only once in OBJ;
1153 that is, whose status is Qt.
1154 Maybe a better way to do that is to copy elements to
1155 a new hash table. */
1156 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vprint_number_table
);
1159 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
1160 if (!NILP (HASH_HASH (h
, i
))
1161 && EQ (HASH_VALUE (h
, i
), Qt
))
1162 Fremhash (HASH_KEY (h
, i
), Vprint_number_table
);
1167 print_object (obj
, printcharfun
, escapeflag
);
1170 /* Construct Vprint_number_table according to the structure of OBJ.
1171 OBJ itself and all its elements will be added to Vprint_number_table
1172 recursively if it is a list, vector, compiled function, char-table,
1173 string (its text properties will be traced), or a symbol that has
1174 no obarray (this is for the print-gensym feature).
1175 The status fields of Vprint_number_table mean whether each object appears
1176 more than once in OBJ: Qnil at the first time, and Qt after that . */
1178 print_preprocess (Lisp_Object obj
)
1183 Lisp_Object halftail
;
1185 /* Give up if we go so deep that print_object will get an error. */
1186 /* See similar code in print_object. */
1187 if (print_depth
>= PRINT_CIRCLE
)
1188 error ("Apparently circular structure being printed");
1190 /* Avoid infinite recursion for circular nested structure
1191 in the case where Vprint_circle is nil. */
1192 if (NILP (Vprint_circle
))
1194 for (i
= 0; i
< print_depth
; i
++)
1195 if (EQ (obj
, being_printed
[i
]))
1197 being_printed
[print_depth
] = obj
;
1204 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1205 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
)
1206 || HASH_TABLE_P (obj
)
1207 || (! NILP (Vprint_gensym
)
1209 && !SYMBOL_INTERNED_P (obj
)))
1211 if (!HASH_TABLE_P (Vprint_number_table
))
1213 Lisp_Object args
[2];
1216 Vprint_number_table
= Fmake_hash_table (2, args
);
1219 /* In case print-circle is nil and print-gensym is t,
1220 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1221 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1223 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1225 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1226 always print the gensym with a number. This is a special for
1227 the lisp function byte-compile-output-docform. */
1228 || (!NILP (Vprint_continuous_numbering
)
1230 && !SYMBOL_INTERNED_P (obj
)))
1231 { /* OBJ appears more than once. Let's remember that. */
1232 if (!INTEGERP (num
))
1234 print_number_index
++;
1235 /* Negative number indicates it hasn't been printed yet. */
1236 Fputhash (obj
, make_number (- print_number_index
),
1237 Vprint_number_table
);
1243 /* OBJ is not yet recorded. Let's add to the table. */
1244 Fputhash (obj
, Qt
, Vprint_number_table
);
1247 switch (XTYPE (obj
))
1250 /* A string may have text properties, which can be circular. */
1251 traverse_intervals_noorder (STRING_INTERVALS (obj
),
1252 print_preprocess_string
, Qnil
);
1256 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1257 just as in print_object. */
1258 if (loop_count
&& EQ (obj
, halftail
))
1260 print_preprocess (XCAR (obj
));
1263 if (!(loop_count
& 1))
1264 halftail
= XCDR (halftail
);
1267 case Lisp_Vectorlike
:
1268 size
= XVECTOR (obj
)->size
;
1269 if (size
& PSEUDOVECTOR_FLAG
)
1270 size
&= PSEUDOVECTOR_SIZE_MASK
;
1271 for (i
= 0; i
< size
; i
++)
1272 print_preprocess (XVECTOR (obj
)->contents
[i
]);
1273 if (HASH_TABLE_P (obj
))
1274 { /* For hash tables, the key_and_value slot is past
1275 `size' because it needs to be marked specially in case
1276 the table is weak. */
1277 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1278 print_preprocess (h
->key_and_value
);
1290 print_preprocess_string (INTERVAL interval
, Lisp_Object arg
)
1292 print_preprocess (interval
->plist
);
1295 static void print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
);
1297 #define PRINT_STRING_NON_CHARSET_FOUND 1
1298 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1300 /* Bitwise or of the above macros. */
1301 static int print_check_string_result
;
1304 print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
)
1308 if (NILP (interval
->plist
)
1309 || (print_check_string_result
== (PRINT_STRING_NON_CHARSET_FOUND
1310 | PRINT_STRING_UNSAFE_CHARSET_FOUND
)))
1312 for (val
= interval
->plist
; CONSP (val
) && ! EQ (XCAR (val
), Qcharset
);
1313 val
= XCDR (XCDR (val
)));
1316 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1319 if (! (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
))
1321 if (! EQ (val
, interval
->plist
)
1322 || CONSP (XCDR (XCDR (val
))))
1323 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1325 if (NILP (Vprint_charset_text_property
)
1326 || ! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1329 EMACS_INT charpos
= interval
->position
;
1330 EMACS_INT bytepos
= string_char_to_byte (string
, charpos
);
1331 Lisp_Object charset
;
1333 charset
= XCAR (XCDR (val
));
1334 for (i
= 0; i
< LENGTH (interval
); i
++)
1336 FETCH_STRING_CHAR_ADVANCE (c
, string
, charpos
, bytepos
);
1337 if (! ASCII_CHAR_P (c
)
1338 && ! EQ (CHARSET_NAME (CHAR_CHARSET (c
)), charset
))
1340 print_check_string_result
|= PRINT_STRING_UNSAFE_CHARSET_FOUND
;
1347 /* The value is (charset . nil). */
1348 static Lisp_Object print_prune_charset_plist
;
1351 print_prune_string_charset (Lisp_Object string
)
1353 print_check_string_result
= 0;
1354 traverse_intervals (STRING_INTERVALS (string
), 0,
1355 print_check_string_charset_prop
, string
);
1356 if (! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1358 string
= Fcopy_sequence (string
);
1359 if (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
)
1361 if (NILP (print_prune_charset_plist
))
1362 print_prune_charset_plist
= Fcons (Qcharset
, Qnil
);
1363 Fremove_text_properties (make_number (0),
1364 make_number (SCHARS (string
)),
1365 print_prune_charset_plist
, string
);
1368 Fset_text_properties (make_number (0), make_number (SCHARS (string
)),
1375 print_object (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
)
1381 /* See similar code in print_preprocess. */
1382 if (print_depth
>= PRINT_CIRCLE
)
1383 error ("Apparently circular structure being printed");
1385 /* Detect circularities and truncate them. */
1386 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1387 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
)
1388 || HASH_TABLE_P (obj
)
1389 || (! NILP (Vprint_gensym
)
1391 && !SYMBOL_INTERNED_P (obj
)))
1393 if (NILP (Vprint_circle
) && NILP (Vprint_gensym
))
1395 /* Simple but incomplete way. */
1397 for (i
= 0; i
< print_depth
; i
++)
1398 if (EQ (obj
, being_printed
[i
]))
1400 sprintf (buf
, "#%d", i
);
1401 strout (buf
, -1, -1, printcharfun
, 0);
1404 being_printed
[print_depth
] = obj
;
1408 /* With the print-circle feature. */
1409 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1414 { /* Add a prefix #n= if OBJ has not yet been printed;
1415 that is, its status field is nil. */
1416 sprintf (buf
, "#%d=", -n
);
1417 strout (buf
, -1, -1, printcharfun
, 0);
1418 /* OBJ is going to be printed. Remember that fact. */
1419 Fputhash (obj
, make_number (- n
), Vprint_number_table
);
1423 /* Just print #n# if OBJ has already been printed. */
1424 sprintf (buf
, "#%d#", n
);
1425 strout (buf
, -1, -1, printcharfun
, 0);
1434 switch (XTYPE (obj
))
1437 if (sizeof (int) == sizeof (EMACS_INT
))
1438 sprintf (buf
, "%d", (int) XINT (obj
));
1439 else if (sizeof (long) == sizeof (EMACS_INT
))
1440 sprintf (buf
, "%ld", (long) XINT (obj
));
1443 strout (buf
, -1, -1, printcharfun
, 0);
1448 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
1450 float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1451 strout (pigbuf
, -1, -1, printcharfun
, 0);
1457 print_string (obj
, printcharfun
);
1460 register EMACS_INT i
, i_byte
;
1461 struct gcpro gcpro1
;
1463 EMACS_INT size_byte
;
1464 /* 1 means we must ensure that the next character we output
1465 cannot be taken as part of a hex character escape. */
1466 int need_nonhex
= 0;
1467 int multibyte
= STRING_MULTIBYTE (obj
);
1471 if (! EQ (Vprint_charset_text_property
, Qt
))
1472 obj
= print_prune_string_charset (obj
);
1474 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1482 size_byte
= SBYTES (obj
);
1484 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1486 /* Here, we must convert each multi-byte form to the
1487 corresponding character code before handing it to PRINTCHAR. */
1493 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
, len
);
1501 if (c
== '\n' && print_escape_newlines
)
1506 else if (c
== '\f' && print_escape_newlines
)
1512 && (CHAR_BYTE8_P (c
)
1513 || (! ASCII_CHAR_P (c
) && print_escape_multibyte
)))
1515 /* When multibyte is disabled,
1516 print multibyte string chars using hex escapes.
1517 For a char code that could be in a unibyte string,
1518 when found in a multibyte string, always use a hex escape
1519 so it reads back as multibyte. */
1520 unsigned char outbuf
[50];
1522 if (CHAR_BYTE8_P (c
))
1523 sprintf (outbuf
, "\\%03o", CHAR_TO_BYTE8 (c
));
1526 sprintf (outbuf
, "\\x%04x", c
);
1529 strout (outbuf
, -1, -1, printcharfun
, 0);
1531 else if (! multibyte
1532 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1533 && print_escape_nonascii
)
1535 /* When printing in a multibyte buffer
1536 or when explicitly requested,
1537 print single-byte non-ASCII string chars
1538 using octal escapes. */
1539 unsigned char outbuf
[5];
1540 sprintf (outbuf
, "\\%03o", c
);
1541 strout (outbuf
, -1, -1, printcharfun
, 0);
1545 /* If we just had a hex escape, and this character
1546 could be taken as part of it,
1547 output `\ ' to prevent that. */
1551 if ((c
>= 'a' && c
<= 'f')
1552 || (c
>= 'A' && c
<= 'F')
1553 || (c
>= '0' && c
<= '9'))
1554 strout ("\\ ", -1, -1, printcharfun
, 0);
1557 if (c
== '\"' || c
== '\\')
1564 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1566 traverse_intervals (STRING_INTERVALS (obj
),
1567 0, print_interval
, printcharfun
);
1577 register int confusing
;
1578 register unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1579 register unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1582 EMACS_INT size_byte
;
1585 name
= SYMBOL_NAME (obj
);
1587 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1590 /* If symbol name begins with a digit, and ends with a digit,
1591 and contains nothing but digits and `e', it could be treated
1592 as a number. So set CONFUSING.
1594 Symbols that contain periods could also be taken as numbers,
1595 but periods are always escaped, so we don't have to worry
1597 else if (*p
>= '0' && *p
<= '9'
1598 && end
[-1] >= '0' && end
[-1] <= '9')
1600 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1601 /* Needed for \2e10. */
1602 || *p
== 'e' || *p
== 'E'))
1604 confusing
= (end
== p
);
1609 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1615 size_byte
= SBYTES (name
);
1617 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1619 /* Here, we must convert each multi-byte form to the
1620 corresponding character code before handing it to PRINTCHAR. */
1621 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1626 if (c
== '\"' || c
== '\\' || c
== '\''
1627 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1628 || c
== ',' || c
=='.' || c
== '`'
1629 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1631 PRINTCHAR ('\\'), confusing
= 0;
1639 /* If deeper than spec'd depth, print placeholder. */
1640 if (INTEGERP (Vprint_level
)
1641 && print_depth
> XINT (Vprint_level
))
1642 strout ("...", -1, -1, printcharfun
, 0);
1643 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1644 && (EQ (XCAR (obj
), Qquote
)))
1647 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1649 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1650 && (EQ (XCAR (obj
), Qfunction
)))
1654 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1656 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1657 && ((EQ (XCAR (obj
), Qbackquote
))))
1659 print_object (XCAR (obj
), printcharfun
, 0);
1660 new_backquote_output
++;
1661 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1662 new_backquote_output
--;
1664 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1665 && new_backquote_output
1666 && ((EQ (XCAR (obj
), Qbackquote
)
1667 || EQ (XCAR (obj
), Qcomma
)
1668 || EQ (XCAR (obj
), Qcomma_at
)
1669 || EQ (XCAR (obj
), Qcomma_dot
))))
1671 print_object (XCAR (obj
), printcharfun
, 0);
1672 new_backquote_output
--;
1673 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1674 new_backquote_output
++;
1680 /* If the first element is a backquote form,
1681 print it old-style so it won't be misunderstood. */
1682 if (print_quoted
&& CONSP (XCAR (obj
))
1683 && CONSP (XCDR (XCAR (obj
)))
1684 && NILP (XCDR (XCDR (XCAR (obj
))))
1685 && EQ (XCAR (XCAR (obj
)), Qbackquote
))
1691 print_object (Qbackquote
, printcharfun
, 0);
1694 print_object (XCAR (XCDR (tem
)), printcharfun
, 0);
1701 EMACS_INT print_length
;
1703 Lisp_Object halftail
= obj
;
1705 /* Negative values of print-length are invalid in CL.
1706 Treat them like nil, as CMUCL does. */
1707 if (NATNUMP (Vprint_length
))
1708 print_length
= XFASTINT (Vprint_length
);
1715 /* Detect circular list. */
1716 if (NILP (Vprint_circle
))
1718 /* Simple but imcomplete way. */
1719 if (i
!= 0 && EQ (obj
, halftail
))
1721 sprintf (buf
, " . #%d", i
/ 2);
1722 strout (buf
, -1, -1, printcharfun
, 0);
1728 /* With the print-circle feature. */
1731 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1734 strout (" . ", 3, 3, printcharfun
, 0);
1735 print_object (obj
, printcharfun
, escapeflag
);
1744 if (print_length
&& i
> print_length
)
1746 strout ("...", 3, 3, printcharfun
, 0);
1750 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1754 halftail
= XCDR (halftail
);
1758 /* OBJ non-nil here means it's the end of a dotted list. */
1761 strout (" . ", 3, 3, printcharfun
, 0);
1762 print_object (obj
, printcharfun
, escapeflag
);
1770 case Lisp_Vectorlike
:
1775 strout ("#<process ", -1, -1, printcharfun
, 0);
1776 print_string (XPROCESS (obj
)->name
, printcharfun
);
1780 print_string (XPROCESS (obj
)->name
, printcharfun
);
1782 else if (BOOL_VECTOR_P (obj
))
1785 register unsigned char c
;
1786 struct gcpro gcpro1
;
1787 EMACS_INT size_in_chars
1788 = ((XBOOL_VECTOR (obj
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
1789 / BOOL_VECTOR_BITS_PER_CHAR
);
1795 sprintf (buf
, "%ld", (long) XBOOL_VECTOR (obj
)->size
);
1796 strout (buf
, -1, -1, printcharfun
, 0);
1799 /* Don't print more characters than the specified maximum.
1800 Negative values of print-length are invalid. Treat them
1801 like a print-length of nil. */
1802 if (NATNUMP (Vprint_length
)
1803 && XFASTINT (Vprint_length
) < size_in_chars
)
1804 size_in_chars
= XFASTINT (Vprint_length
);
1806 for (i
= 0; i
< size_in_chars
; i
++)
1809 c
= XBOOL_VECTOR (obj
)->data
[i
];
1810 if (c
== '\n' && print_escape_newlines
)
1815 else if (c
== '\f' && print_escape_newlines
)
1820 else if (c
> '\177')
1822 /* Use octal escapes to avoid encoding issues. */
1824 PRINTCHAR ('0' + ((c
>> 6) & 3));
1825 PRINTCHAR ('0' + ((c
>> 3) & 7));
1826 PRINTCHAR ('0' + (c
& 7));
1830 if (c
== '\"' || c
== '\\')
1839 else if (SUBRP (obj
))
1841 strout ("#<subr ", -1, -1, printcharfun
, 0);
1842 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
, 0);
1845 else if (WINDOWP (obj
))
1847 strout ("#<window ", -1, -1, printcharfun
, 0);
1848 sprintf (buf
, "%ld", (long) XFASTINT (XWINDOW (obj
)->sequence_number
));
1849 strout (buf
, -1, -1, printcharfun
, 0);
1850 if (!NILP (XWINDOW (obj
)->buffer
))
1852 strout (" on ", -1, -1, printcharfun
, 0);
1853 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1857 else if (TERMINALP (obj
))
1859 struct terminal
*t
= XTERMINAL (obj
);
1860 strout ("#<terminal ", -1, -1, printcharfun
, 0);
1861 sprintf (buf
, "%d", t
->id
);
1862 strout (buf
, -1, -1, printcharfun
, 0);
1865 strout (" on ", -1, -1, printcharfun
, 0);
1866 strout (t
->name
, -1, -1, printcharfun
, 0);
1870 else if (HASH_TABLE_P (obj
))
1872 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1874 EMACS_INT real_size
, size
;
1876 strout ("#<hash-table", -1, -1, printcharfun
, 0);
1877 if (SYMBOLP (h
->test
))
1881 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
, 0);
1883 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
, 0);
1885 sprintf (buf
, "%ld/%ld", (long) h
->count
,
1886 (long) XVECTOR (h
->next
)->size
);
1887 strout (buf
, -1, -1, printcharfun
, 0);
1889 sprintf (buf
, " 0x%lx", (unsigned long) h
);
1890 strout (buf
, -1, -1, printcharfun
, 0);
1893 /* Implement a readable output, e.g.:
1894 #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
1895 /* Always print the size. */
1896 sprintf (buf
, "#s(hash-table size %ld",
1897 (long) XVECTOR (h
->next
)->size
);
1898 strout (buf
, -1, -1, printcharfun
, 0);
1900 if (!NILP (h
->test
))
1902 strout (" test ", -1, -1, printcharfun
, 0);
1903 print_object (h
->test
, printcharfun
, 0);
1906 if (!NILP (h
->weak
))
1908 strout (" weakness ", -1, -1, printcharfun
, 0);
1909 print_object (h
->weak
, printcharfun
, 0);
1912 if (!NILP (h
->rehash_size
))
1914 strout (" rehash-size ", -1, -1, printcharfun
, 0);
1915 print_object (h
->rehash_size
, printcharfun
, 0);
1918 if (!NILP (h
->rehash_threshold
))
1920 strout (" rehash-threshold ", -1, -1, printcharfun
, 0);
1921 print_object (h
->rehash_threshold
, printcharfun
, 0);
1924 strout (" data ", -1, -1, printcharfun
, 0);
1926 /* Print the data here as a plist. */
1927 real_size
= HASH_TABLE_SIZE (h
);
1930 /* Don't print more elements than the specified maximum. */
1931 if (NATNUMP (Vprint_length
)
1932 && XFASTINT (Vprint_length
) < size
)
1933 size
= XFASTINT (Vprint_length
);
1936 for (i
= 0; i
< size
; i
++)
1937 if (!NILP (HASH_HASH (h
, i
)))
1939 if (i
) PRINTCHAR (' ');
1940 print_object (HASH_KEY (h
, i
), printcharfun
, 1);
1942 print_object (HASH_VALUE (h
, i
), printcharfun
, 1);
1945 if (size
< real_size
)
1946 strout (" ...", 4, 4, printcharfun
, 0);
1952 else if (BUFFERP (obj
))
1954 if (NILP (XBUFFER (obj
)->name
))
1955 strout ("#<killed buffer>", -1, -1, printcharfun
, 0);
1956 else if (escapeflag
)
1958 strout ("#<buffer ", -1, -1, printcharfun
, 0);
1959 print_string (XBUFFER (obj
)->name
, printcharfun
);
1963 print_string (XBUFFER (obj
)->name
, printcharfun
);
1965 else if (WINDOW_CONFIGURATIONP (obj
))
1967 strout ("#<window-configuration>", -1, -1, printcharfun
, 0);
1969 else if (FRAMEP (obj
))
1971 strout ((FRAME_LIVE_P (XFRAME (obj
))
1972 ? "#<frame " : "#<dead frame "),
1973 -1, -1, printcharfun
, 0);
1974 print_string (XFRAME (obj
)->name
, printcharfun
);
1975 sprintf (buf
, " 0x%lx", (unsigned long) (XFRAME (obj
)));
1976 strout (buf
, -1, -1, printcharfun
, 0);
1979 else if (FONTP (obj
))
1983 if (! FONT_OBJECT_P (obj
))
1985 if (FONT_SPEC_P (obj
))
1986 strout ("#<font-spec", -1, -1, printcharfun
, 0);
1988 strout ("#<font-entity", -1, -1, printcharfun
, 0);
1989 for (i
= 0; i
< FONT_SPEC_MAX
; i
++)
1992 if (i
< FONT_WEIGHT_INDEX
|| i
> FONT_WIDTH_INDEX
)
1993 print_object (AREF (obj
, i
), printcharfun
, escapeflag
);
1995 print_object (font_style_symbolic (obj
, i
, 0),
1996 printcharfun
, escapeflag
);
2001 strout ("#<font-object ", -1, -1, printcharfun
, 0);
2002 print_object (AREF (obj
, FONT_NAME_INDEX
), printcharfun
,
2009 EMACS_INT size
= XVECTOR (obj
)->size
;
2010 if (COMPILEDP (obj
))
2013 size
&= PSEUDOVECTOR_SIZE_MASK
;
2015 if (CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
))
2017 /* We print a char-table as if it were a vector,
2018 lumping the parent and default slots in with the
2019 character slots. But we add #^ as a prefix. */
2021 /* Make each lowest sub_char_table start a new line.
2022 Otherwise we'll make a line extremely long, which
2023 results in slow redisplay. */
2024 if (SUB_CHAR_TABLE_P (obj
)
2025 && XINT (XSUB_CHAR_TABLE (obj
)->depth
) == 3)
2029 if (SUB_CHAR_TABLE_P (obj
))
2031 size
&= PSEUDOVECTOR_SIZE_MASK
;
2033 if (size
& PSEUDOVECTOR_FLAG
)
2039 register Lisp_Object tem
;
2040 EMACS_INT real_size
= size
;
2042 /* Don't print more elements than the specified maximum. */
2043 if (NATNUMP (Vprint_length
)
2044 && XFASTINT (Vprint_length
) < size
)
2045 size
= XFASTINT (Vprint_length
);
2047 for (i
= 0; i
< size
; i
++)
2049 if (i
) PRINTCHAR (' ');
2050 tem
= XVECTOR (obj
)->contents
[i
];
2051 print_object (tem
, printcharfun
, escapeflag
);
2053 if (size
< real_size
)
2054 strout (" ...", 4, 4, printcharfun
, 0);
2061 switch (XMISCTYPE (obj
))
2063 case Lisp_Misc_Marker
:
2064 strout ("#<marker ", -1, -1, printcharfun
, 0);
2065 /* Do you think this is necessary? */
2066 if (XMARKER (obj
)->insertion_type
!= 0)
2067 strout ("(moves after insertion) ", -1, -1, printcharfun
, 0);
2068 if (! XMARKER (obj
)->buffer
)
2069 strout ("in no buffer", -1, -1, printcharfun
, 0);
2072 sprintf (buf
, "at %ld", (long)marker_position (obj
));
2073 strout (buf
, -1, -1, printcharfun
, 0);
2074 strout (" in ", -1, -1, printcharfun
, 0);
2075 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
2080 case Lisp_Misc_Overlay
:
2081 strout ("#<overlay ", -1, -1, printcharfun
, 0);
2082 if (! XMARKER (OVERLAY_START (obj
))->buffer
)
2083 strout ("in no buffer", -1, -1, printcharfun
, 0);
2086 sprintf (buf
, "from %ld to %ld in ",
2087 (long)marker_position (OVERLAY_START (obj
)),
2088 (long)marker_position (OVERLAY_END (obj
)));
2089 strout (buf
, -1, -1, printcharfun
, 0);
2090 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
2096 /* Remaining cases shouldn't happen in normal usage, but let's print
2097 them anyway for the benefit of the debugger. */
2098 case Lisp_Misc_Free
:
2099 strout ("#<misc free cell>", -1, -1, printcharfun
, 0);
2102 case Lisp_Misc_Save_Value
:
2103 strout ("#<save_value ", -1, -1, printcharfun
, 0);
2104 sprintf(buf
, "ptr=0x%08lx int=%d",
2105 (unsigned long) XSAVE_VALUE (obj
)->pointer
,
2106 XSAVE_VALUE (obj
)->integer
);
2107 strout (buf
, -1, -1, printcharfun
, 0);
2119 /* We're in trouble if this happens!
2120 Probably should just abort () */
2121 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
, 0);
2123 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2124 else if (VECTORLIKEP (obj
))
2125 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
2127 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2128 strout (buf
, -1, -1, printcharfun
, 0);
2129 strout (" Save your buffers immediately and please report this bug>",
2130 -1, -1, printcharfun
, 0);
2138 /* Print a description of INTERVAL using PRINTCHARFUN.
2139 This is part of printing a string that has text properties. */
2142 print_interval (INTERVAL interval
, Lisp_Object printcharfun
)
2144 if (NILP (interval
->plist
))
2147 print_object (make_number (interval
->position
), printcharfun
, 1);
2149 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2152 print_object (interval
->plist
, printcharfun
, 1);
2157 syms_of_print (void)
2159 Qtemp_buffer_setup_hook
= intern_c_string ("temp-buffer-setup-hook");
2160 staticpro (&Qtemp_buffer_setup_hook
);
2162 DEFVAR_LISP ("standard-output", Vstandard_output
,
2163 doc
: /* Output stream `print' uses by default for outputting a character.
2164 This may be any function of one argument.
2165 It may also be a buffer (output is inserted before point)
2166 or a marker (output is inserted and the marker is advanced)
2167 or the symbol t (output appears in the echo area). */);
2168 Vstandard_output
= Qt
;
2169 Qstandard_output
= intern_c_string ("standard-output");
2170 staticpro (&Qstandard_output
);
2172 DEFVAR_LISP ("float-output-format", Vfloat_output_format
,
2173 doc
: /* The format descriptor string used to print floats.
2174 This is a %-spec like those accepted by `printf' in C,
2175 but with some restrictions. It must start with the two characters `%.'.
2176 After that comes an integer precision specification,
2177 and then a letter which controls the format.
2178 The letters allowed are `e', `f' and `g'.
2179 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2180 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2181 Use `g' to choose the shorter of those two formats for the number at hand.
2182 The precision in any of these cases is the number of digits following
2183 the decimal point. With `f', a precision of 0 means to omit the
2184 decimal point. 0 is not allowed with `e' or `g'.
2186 A value of nil means to use the shortest notation
2187 that represents the number without losing information. */);
2188 Vfloat_output_format
= Qnil
;
2189 Qfloat_output_format
= intern_c_string ("float-output-format");
2190 staticpro (&Qfloat_output_format
);
2192 DEFVAR_LISP ("print-length", Vprint_length
,
2193 doc
: /* Maximum length of list to print before abbreviating.
2194 A value of nil means no limit. See also `eval-expression-print-length'. */);
2195 Vprint_length
= Qnil
;
2197 DEFVAR_LISP ("print-level", Vprint_level
,
2198 doc
: /* Maximum depth of list nesting to print before abbreviating.
2199 A value of nil means no limit. See also `eval-expression-print-level'. */);
2200 Vprint_level
= Qnil
;
2202 DEFVAR_BOOL ("print-escape-newlines", print_escape_newlines
,
2203 doc
: /* Non-nil means print newlines in strings as `\\n'.
2204 Also print formfeeds as `\\f'. */);
2205 print_escape_newlines
= 0;
2207 DEFVAR_BOOL ("print-escape-nonascii", print_escape_nonascii
,
2208 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2209 \(OOO is the octal representation of the character code.)
2210 Only single-byte characters are affected, and only in `prin1'.
2211 When the output goes in a multibyte buffer, this feature is
2212 enabled regardless of the value of the variable. */);
2213 print_escape_nonascii
= 0;
2215 DEFVAR_BOOL ("print-escape-multibyte", print_escape_multibyte
,
2216 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2217 \(XXXX is the hex representation of the character code.)
2218 This affects only `prin1'. */);
2219 print_escape_multibyte
= 0;
2221 DEFVAR_BOOL ("print-quoted", print_quoted
,
2222 doc
: /* Non-nil means print quoted forms with reader syntax.
2223 I.e., (quote foo) prints as 'foo, (function foo) as #'foo. */);
2226 DEFVAR_LISP ("print-gensym", Vprint_gensym
,
2227 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2228 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2229 When the uninterned symbol appears within a recursive data structure,
2230 and the symbol appears more than once, in addition use the #N# and #N=
2231 constructs as needed, so that multiple references to the same symbol are
2232 shared once again when the text is read back. */);
2233 Vprint_gensym
= Qnil
;
2235 DEFVAR_LISP ("print-circle", Vprint_circle
,
2236 doc
: /* *Non-nil means print recursive structures using #N= and #N# syntax.
2237 If nil, printing proceeds recursively and may lead to
2238 `max-lisp-eval-depth' being exceeded or an error may occur:
2239 \"Apparently circular structure being printed.\" Also see
2240 `print-length' and `print-level'.
2241 If non-nil, shared substructures anywhere in the structure are printed
2242 with `#N=' before the first occurrence (in the order of the print
2243 representation) and `#N#' in place of each subsequent occurrence,
2244 where N is a positive decimal integer. */);
2245 Vprint_circle
= Qnil
;
2247 DEFVAR_LISP ("print-continuous-numbering", Vprint_continuous_numbering
,
2248 doc
: /* *Non-nil means number continuously across print calls.
2249 This affects the numbers printed for #N= labels and #M# references.
2250 See also `print-circle', `print-gensym', and `print-number-table'.
2251 This variable should not be set with `setq'; bind it with a `let' instead. */);
2252 Vprint_continuous_numbering
= Qnil
;
2254 DEFVAR_LISP ("print-number-table", Vprint_number_table
,
2255 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2256 The Lisp printer uses this vector to detect Lisp objects referenced more
2259 When you bind `print-continuous-numbering' to t, you should probably
2260 also bind `print-number-table' to nil. This ensures that the value of
2261 `print-number-table' can be garbage-collected once the printing is
2262 done. If all elements of `print-number-table' are nil, it means that
2263 the printing done so far has not found any shared structure or objects
2264 that need to be recorded in the table. */);
2265 Vprint_number_table
= Qnil
;
2267 DEFVAR_LISP ("print-charset-text-property", Vprint_charset_text_property
,
2268 doc
: /* A flag to control printing of `charset' text property on printing a string.
2269 The value must be nil, t, or `default'.
2271 If the value is nil, don't print the text property `charset'.
2273 If the value is t, always print the text property `charset'.
2275 If the value is `default', print the text property `charset' only when
2276 the value is different from what is guessed in the current charset
2278 Vprint_charset_text_property
= Qdefault
;
2280 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2281 staticpro (&Vprin1_to_string_buffer
);
2284 defsubr (&Sprin1_to_string
);
2285 defsubr (&Serror_message_string
);
2289 defsubr (&Swrite_char
);
2290 defsubr (&Sexternal_debugging_output
);
2291 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2292 defsubr (&Sredirect_debugging_output
);
2295 Qexternal_debugging_output
= intern_c_string ("external-debugging-output");
2296 staticpro (&Qexternal_debugging_output
);
2298 Qprint_escape_newlines
= intern_c_string ("print-escape-newlines");
2299 staticpro (&Qprint_escape_newlines
);
2301 Qprint_escape_multibyte
= intern_c_string ("print-escape-multibyte");
2302 staticpro (&Qprint_escape_multibyte
);
2304 Qprint_escape_nonascii
= intern_c_string ("print-escape-nonascii");
2305 staticpro (&Qprint_escape_nonascii
);
2307 print_prune_charset_plist
= Qnil
;
2308 staticpro (&print_prune_charset_plist
);
2310 defsubr (&Swith_output_to_temp_buffer
);