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 (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 (current_buffer->enable_multibyte_characters) \
148 && ! print_escape_multibyte) \
149 specbind (Qprint_escape_multibyte, Qt); \
150 if (! NILP (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 (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 (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
, int multibyte
)
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 (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 (buffer_defaults
.enable_multibyte_characters
)
375 : ! NILP (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
),
410 printcharfun
, STRING_MULTIBYTE (string
));
415 /* No need to copy, since output to print_buffer can't GC. */
416 strout (SSDATA (string
),
417 chars
, SBYTES (string
),
418 printcharfun
, STRING_MULTIBYTE (string
));
422 /* Otherwise, string may be relocated by printing one char.
423 So re-fetch the string address for each character. */
425 EMACS_INT size
= SCHARS (string
);
426 EMACS_INT size_byte
= SBYTES (string
);
429 if (size
== size_byte
)
430 for (i
= 0; i
< size
; i
++)
431 PRINTCHAR (SREF (string
, i
));
433 for (i
= 0; i
< size_byte
; )
435 /* Here, we must convert each multi-byte form to the
436 corresponding character code before handing it to PRINTCHAR. */
438 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
, len
);
446 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
447 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
448 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
449 (Lisp_Object character
, Lisp_Object printcharfun
)
453 if (NILP (printcharfun
))
454 printcharfun
= Vstandard_output
;
455 CHECK_NUMBER (character
);
457 PRINTCHAR (XINT (character
));
462 /* Used from outside of print.c to print a block of SIZE
463 single-byte chars at DATA on the default output stream.
464 Do not use this on the contents of a Lisp string. */
467 write_string (const char *data
, int size
)
470 Lisp_Object printcharfun
;
472 printcharfun
= Vstandard_output
;
475 strout (data
, size
, size
, printcharfun
, 0);
479 /* Used to print a block of SIZE single-byte chars at DATA on a
480 specified stream PRINTCHARFUN.
481 Do not use this on the contents of a Lisp string. */
484 write_string_1 (const char *data
, int size
, Lisp_Object printcharfun
)
489 strout (data
, size
, size
, printcharfun
, 0);
495 temp_output_buffer_setup (const char *bufname
)
497 int count
= SPECPDL_INDEX ();
498 register struct buffer
*old
= current_buffer
;
499 register Lisp_Object buf
;
501 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
503 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
505 Fkill_all_local_variables ();
506 delete_all_overlays (current_buffer
);
507 current_buffer
->directory
= old
->directory
;
508 current_buffer
->read_only
= Qnil
;
509 current_buffer
->filename
= Qnil
;
510 current_buffer
->undo_list
= Qt
;
511 eassert (current_buffer
->overlays_before
== NULL
);
512 eassert (current_buffer
->overlays_after
== NULL
);
513 current_buffer
->enable_multibyte_characters
514 = buffer_defaults
.enable_multibyte_characters
;
515 specbind (Qinhibit_read_only
, Qt
);
516 specbind (Qinhibit_modification_hooks
, Qt
);
518 XSETBUFFER (buf
, current_buffer
);
520 Frun_hooks (1, &Qtemp_buffer_setup_hook
);
522 unbind_to (count
, Qnil
);
524 specbind (Qstandard_output
, buf
);
528 internal_with_output_to_temp_buffer (const char *bufname
, Lisp_Object (*function
) (Lisp_Object
), Lisp_Object args
)
530 int count
= SPECPDL_INDEX ();
531 Lisp_Object buf
, val
;
535 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
536 temp_output_buffer_setup (bufname
);
537 buf
= Vstandard_output
;
540 val
= (*function
) (args
);
543 temp_output_buffer_show (buf
);
546 return unbind_to (count
, val
);
549 DEFUN ("with-output-to-temp-buffer",
550 Fwith_output_to_temp_buffer
, Swith_output_to_temp_buffer
,
552 doc
: /* Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
554 This construct makes buffer BUFNAME empty before running BODY.
555 It does not make the buffer current for BODY.
556 Instead it binds `standard-output' to that buffer, so that output
557 generated with `prin1' and similar functions in BODY goes into
560 At the end of BODY, this marks buffer BUFNAME unmodifed and displays
561 it in a window, but does not select it. The normal way to do this is
562 by calling `display-buffer', then running `temp-buffer-show-hook'.
563 However, if `temp-buffer-show-function' is non-nil, it calls that
564 function instead (and does not run `temp-buffer-show-hook'). The
565 function gets one argument, the buffer to display.
567 The return value of `with-output-to-temp-buffer' is the value of the
568 last form in BODY. If BODY does not finish normally, the buffer
569 BUFNAME is not displayed.
571 This runs the hook `temp-buffer-setup-hook' before BODY,
572 with the buffer BUFNAME temporarily current. It runs the hook
573 `temp-buffer-show-hook' after displaying buffer BUFNAME, with that
574 buffer temporarily current, and the window that was used to display it
575 temporarily selected. But it doesn't run `temp-buffer-show-hook'
576 if it uses `temp-buffer-show-function'.
578 usage: (with-output-to-temp-buffer BUFNAME BODY...) */)
583 int count
= SPECPDL_INDEX ();
584 Lisp_Object buf
, val
;
587 name
= eval_sub (Fcar (args
));
589 temp_output_buffer_setup (SSDATA (name
));
590 buf
= Vstandard_output
;
593 val
= Fprogn (XCDR (args
));
596 temp_output_buffer_show (buf
);
599 return unbind_to (count
, val
);
603 static void print (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
);
604 static void print_preprocess (Lisp_Object obj
);
605 static void print_preprocess_string (INTERVAL interval
, Lisp_Object arg
);
606 static void print_object (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
);
608 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
609 doc
: /* Output a newline to stream PRINTCHARFUN.
610 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
611 (Lisp_Object printcharfun
)
615 if (NILP (printcharfun
))
616 printcharfun
= Vstandard_output
;
623 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
624 doc
: /* Output the printed representation of OBJECT, any Lisp object.
625 Quoting characters are printed when needed to make output that `read'
626 can handle, whenever this is possible. For complex objects, the behavior
627 is controlled by `print-level' and `print-length', which see.
629 OBJECT is any of the Lisp data types: a number, a string, a symbol,
630 a list, a buffer, a window, a frame, etc.
632 A printed representation of an object is text which describes that object.
634 Optional argument PRINTCHARFUN is the output stream, which can be one
637 - a buffer, in which case output is inserted into that buffer at point;
638 - a marker, in which case output is inserted at marker's position;
639 - a function, in which case that function is called once for each
640 character of OBJECT's printed representation;
641 - a symbol, in which case that symbol's function definition is called; or
642 - t, in which case the output is displayed in the echo area.
644 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
646 (Lisp_Object object
, Lisp_Object printcharfun
)
650 if (NILP (printcharfun
))
651 printcharfun
= Vstandard_output
;
653 print (object
, printcharfun
, 1);
658 /* a buffer which is used to hold output being built by prin1-to-string */
659 Lisp_Object Vprin1_to_string_buffer
;
661 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
662 doc
: /* Return a string containing the printed representation of OBJECT.
663 OBJECT can be any Lisp object. This function outputs quoting characters
664 when necessary to make output that `read' can handle, whenever possible,
665 unless the optional second argument NOESCAPE is non-nil. For complex objects,
666 the behavior is controlled by `print-level' and `print-length', which see.
668 OBJECT is any of the Lisp data types: a number, a string, a symbol,
669 a list, a buffer, a window, a frame, etc.
671 A printed representation of an object is text which describes that object. */)
672 (Lisp_Object object
, Lisp_Object noescape
)
674 Lisp_Object printcharfun
;
675 /* struct gcpro gcpro1, gcpro2; */
676 Lisp_Object save_deactivate_mark
;
677 int count
= SPECPDL_INDEX ();
678 struct buffer
*previous
;
680 specbind (Qinhibit_modification_hooks
, Qt
);
685 /* Save and restore this--we are altering a buffer
686 but we don't want to deactivate the mark just for that.
687 No need for specbind, since errors deactivate the mark. */
688 save_deactivate_mark
= Vdeactivate_mark
;
689 /* GCPRO2 (object, save_deactivate_mark); */
692 printcharfun
= Vprin1_to_string_buffer
;
694 print (object
, printcharfun
, NILP (noescape
));
695 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
699 previous
= current_buffer
;
700 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
701 object
= Fbuffer_string ();
702 if (SBYTES (object
) == SCHARS (object
))
703 STRING_SET_UNIBYTE (object
);
705 /* Note that this won't make prepare_to_modify_buffer call
706 ask-user-about-supersession-threat because this buffer
707 does not visit a file. */
709 set_buffer_internal (previous
);
711 Vdeactivate_mark
= save_deactivate_mark
;
715 return unbind_to (count
, object
);
718 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
719 doc
: /* Output the printed representation of OBJECT, any Lisp object.
720 No quoting characters are used; no delimiters are printed around
721 the contents of strings.
723 OBJECT is any of the Lisp data types: a number, a string, a symbol,
724 a list, a buffer, a window, a frame, etc.
726 A printed representation of an object is text which describes that object.
728 Optional argument PRINTCHARFUN is the output stream, which can be one
731 - a buffer, in which case output is inserted into that buffer at point;
732 - a marker, in which case output is inserted at marker's position;
733 - a function, in which case that function is called once for each
734 character of OBJECT's printed representation;
735 - a symbol, in which case that symbol's function definition is called; or
736 - t, in which case the output is displayed in the echo area.
738 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
740 (Lisp_Object object
, Lisp_Object printcharfun
)
744 if (NILP (printcharfun
))
745 printcharfun
= Vstandard_output
;
747 print (object
, printcharfun
, 0);
752 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
753 doc
: /* Output the printed representation of OBJECT, with newlines around it.
754 Quoting characters are printed when needed to make output that `read'
755 can handle, whenever this is possible. For complex objects, the behavior
756 is controlled by `print-level' and `print-length', which see.
758 OBJECT is any of the Lisp data types: a number, a string, a symbol,
759 a list, a buffer, a window, a frame, etc.
761 A printed representation of an object is text which describes that object.
763 Optional argument PRINTCHARFUN is the output stream, which can be one
766 - a buffer, in which case output is inserted into that buffer at point;
767 - a marker, in which case output is inserted at marker's position;
768 - a function, in which case that function is called once for each
769 character of OBJECT's printed representation;
770 - a symbol, in which case that symbol's function definition is called; or
771 - t, in which case the output is displayed in the echo area.
773 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
775 (Lisp_Object object
, Lisp_Object printcharfun
)
780 if (NILP (printcharfun
))
781 printcharfun
= Vstandard_output
;
785 print (object
, printcharfun
, 1);
792 /* The subroutine object for external-debugging-output is kept here
793 for the convenience of the debugger. */
794 Lisp_Object Qexternal_debugging_output
;
796 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
797 doc
: /* Write CHARACTER to stderr.
798 You can call print while debugging emacs, and pass it this function
799 to make it write to the debugging output. */)
800 (Lisp_Object character
)
802 CHECK_NUMBER (character
);
803 putc ((int) XINT (character
), stderr
);
806 /* Send the output to a debugger (nothing happens if there isn't one). */
807 if (print_output_debug_flag
)
809 char buf
[2] = {(char) XINT (character
), '\0'};
810 OutputDebugString (buf
);
817 /* This function is never called. Its purpose is to prevent
818 print_output_debug_flag from being optimized away. */
821 debug_output_compilation_hack (int x
)
823 print_output_debug_flag
= x
;
826 #if defined (GNU_LINUX)
828 /* This functionality is not vitally important in general, so we rely on
829 non-portable ability to use stderr as lvalue. */
831 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
833 FILE *initial_stderr_stream
= NULL
;
835 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
837 "FDebug output file: \nP",
838 doc
: /* Redirect debugging output (stderr stream) to file FILE.
839 If FILE is nil, reset target to the initial stderr stream.
840 Optional arg APPEND non-nil (interactively, with prefix arg) means
841 append to existing target file. */)
842 (Lisp_Object file
, Lisp_Object append
)
844 if (initial_stderr_stream
!= NULL
)
850 stderr
= initial_stderr_stream
;
851 initial_stderr_stream
= NULL
;
855 file
= Fexpand_file_name (file
, Qnil
);
856 initial_stderr_stream
= stderr
;
857 stderr
= fopen (SDATA (file
), NILP (append
) ? "w" : "a");
860 stderr
= initial_stderr_stream
;
861 initial_stderr_stream
= NULL
;
862 report_file_error ("Cannot open debugging output stream",
868 #endif /* GNU_LINUX */
871 /* This is the interface for debugging printing. */
874 debug_print (Lisp_Object arg
)
876 Fprin1 (arg
, Qexternal_debugging_output
);
877 fprintf (stderr
, "\r\n");
881 safe_debug_print (Lisp_Object arg
)
883 int valid
= valid_lisp_object_p (arg
);
888 fprintf (stderr
, "#<%s_LISP_OBJECT 0x%08lx>\r\n",
889 !valid
? "INVALID" : "SOME",
890 (unsigned long) XHASH (arg
)
895 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
897 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
898 See Info anchor `(elisp)Definition of signal' for some details on how this
899 error message is constructed. */)
902 struct buffer
*old
= current_buffer
;
906 /* If OBJ is (error STRING), just return STRING.
907 That is not only faster, it also avoids the need to allocate
908 space here when the error is due to memory full. */
909 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
910 && CONSP (XCDR (obj
))
911 && STRINGP (XCAR (XCDR (obj
)))
912 && NILP (XCDR (XCDR (obj
))))
913 return XCAR (XCDR (obj
));
915 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
917 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
918 value
= Fbuffer_string ();
922 set_buffer_internal (old
);
928 /* Print an error message for the error DATA onto Lisp output stream
929 STREAM (suitable for the print functions).
930 CONTEXT is a C string describing the context of the error.
931 CALLER is the Lisp function inside which the error was signaled. */
934 print_error_message (Lisp_Object data
, Lisp_Object stream
, const char *context
,
937 Lisp_Object errname
, errmsg
, file_error
, tail
;
942 write_string_1 (context
, -1, stream
);
944 /* If we know from where the error was signaled, show it in
946 if (!NILP (caller
) && SYMBOLP (caller
))
948 Lisp_Object cname
= SYMBOL_NAME (caller
);
949 char *name
= alloca (SBYTES (cname
));
950 memcpy (name
, SDATA (cname
), SBYTES (cname
));
951 message_dolog (name
, SBYTES (cname
), 0, 0);
952 message_dolog (": ", 2, 0, 0);
955 errname
= Fcar (data
);
957 if (EQ (errname
, Qerror
))
962 errmsg
= Fcar (data
);
967 Lisp_Object error_conditions
;
968 errmsg
= Fget (errname
, Qerror_message
);
969 error_conditions
= Fget (errname
, Qerror_conditions
);
970 file_error
= Fmemq (Qfile_error
, error_conditions
);
973 /* Print an error message including the data items. */
975 tail
= Fcdr_safe (data
);
978 /* For file-error, make error message by concatenating
979 all the data items. They are all strings. */
980 if (!NILP (file_error
) && CONSP (tail
))
981 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
983 if (STRINGP (errmsg
))
984 Fprinc (errmsg
, stream
);
986 write_string_1 ("peculiar error", -1, stream
);
988 for (i
= 0; CONSP (tail
); tail
= XCDR (tail
), i
++)
992 write_string_1 (i
? ", " : ": ", 2, stream
);
994 if (!NILP (file_error
) || EQ (errname
, Qend_of_file
))
995 Fprinc (obj
, stream
);
997 Fprin1 (obj
, stream
);
1006 * The buffer should be at least as large as the max string size of the
1007 * largest float, printed in the biggest notation. This is undoubtedly
1008 * 20d float_output_format, with the negative of the C-constant "HUGE"
1011 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
1013 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
1014 * case of -1e307 in 20d float_output_format. What is one to do (short of
1015 * re-writing _doprnt to be more sane)?
1017 * Given the above, the buffer must be least FLOAT_TO_STRING_BUFSIZE bytes.
1021 float_to_string (char *buf
, double data
)
1026 /* Check for plus infinity in a way that won't lose
1027 if there is no plus infinity. */
1028 if (data
== data
/ 2 && data
> 1.0)
1030 strcpy (buf
, "1.0e+INF");
1033 /* Likewise for minus infinity. */
1034 if (data
== data
/ 2 && data
< -1.0)
1036 strcpy (buf
, "-1.0e+INF");
1039 /* Check for NaN in a way that won't fail if there are no NaNs. */
1040 if (! (data
* 0.0 >= 0.0))
1042 /* Prepend "-" if the NaN's sign bit is negative.
1043 The sign bit of a double is the bit that is 1 in -0.0. */
1045 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
1047 u_minus_zero
.d
= - 0.0;
1048 for (i
= 0; i
< sizeof (double); i
++)
1049 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
1055 strcpy (buf
, "0.0e+NaN");
1059 if (NILP (Vfloat_output_format
)
1060 || !STRINGP (Vfloat_output_format
))
1063 /* Generate the fewest number of digits that represent the
1064 floating point value without losing information. */
1065 dtoastr (buf
, FLOAT_TO_STRING_BUFSIZE
, 0, 0, data
);
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)
1132 print (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
)
1134 new_backquote_output
= 0;
1136 /* Reset print_number_index and Vprint_number_table only when
1137 the variable Vprint_continuous_numbering is nil. Otherwise,
1138 the values of these variables will be kept between several
1140 if (NILP (Vprint_continuous_numbering
)
1141 || NILP (Vprint_number_table
))
1143 print_number_index
= 0;
1144 Vprint_number_table
= Qnil
;
1147 /* Construct Vprint_number_table for print-gensym and print-circle. */
1148 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1150 /* Construct Vprint_number_table.
1151 This increments print_number_index for the objects added. */
1153 print_preprocess (obj
);
1155 if (HASH_TABLE_P (Vprint_number_table
))
1156 { /* Remove unnecessary objects, which appear only once in OBJ;
1157 that is, whose status is Qt.
1158 Maybe a better way to do that is to copy elements to
1159 a new hash table. */
1160 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vprint_number_table
);
1163 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
1164 if (!NILP (HASH_HASH (h
, i
))
1165 && EQ (HASH_VALUE (h
, i
), Qt
))
1166 Fremhash (HASH_KEY (h
, i
), Vprint_number_table
);
1171 print_object (obj
, printcharfun
, escapeflag
);
1174 /* Construct Vprint_number_table according to the structure of OBJ.
1175 OBJ itself and all its elements will be added to Vprint_number_table
1176 recursively if it is a list, vector, compiled function, char-table,
1177 string (its text properties will be traced), or a symbol that has
1178 no obarray (this is for the print-gensym feature).
1179 The status fields of Vprint_number_table mean whether each object appears
1180 more than once in OBJ: Qnil at the first time, and Qt after that . */
1182 print_preprocess (Lisp_Object obj
)
1187 Lisp_Object halftail
;
1189 /* Give up if we go so deep that print_object will get an error. */
1190 /* See similar code in print_object. */
1191 if (print_depth
>= PRINT_CIRCLE
)
1192 error ("Apparently circular structure being printed");
1194 /* Avoid infinite recursion for circular nested structure
1195 in the case where Vprint_circle is nil. */
1196 if (NILP (Vprint_circle
))
1198 for (i
= 0; i
< print_depth
; i
++)
1199 if (EQ (obj
, being_printed
[i
]))
1201 being_printed
[print_depth
] = obj
;
1208 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1209 || FUNVECP (obj
) || CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
)
1210 || HASH_TABLE_P (obj
)
1211 || (! NILP (Vprint_gensym
)
1213 && !SYMBOL_INTERNED_P (obj
)))
1215 if (!HASH_TABLE_P (Vprint_number_table
))
1217 Lisp_Object args
[2];
1220 Vprint_number_table
= Fmake_hash_table (2, args
);
1223 /* In case print-circle is nil and print-gensym is t,
1224 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1225 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1227 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1229 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1230 always print the gensym with a number. This is a special for
1231 the lisp function byte-compile-output-docform. */
1232 || (!NILP (Vprint_continuous_numbering
)
1234 && !SYMBOL_INTERNED_P (obj
)))
1235 { /* OBJ appears more than once. Let's remember that. */
1236 if (!INTEGERP (num
))
1238 print_number_index
++;
1239 /* Negative number indicates it hasn't been printed yet. */
1240 Fputhash (obj
, make_number (- print_number_index
),
1241 Vprint_number_table
);
1247 /* OBJ is not yet recorded. Let's add to the table. */
1248 Fputhash (obj
, Qt
, Vprint_number_table
);
1251 switch (XTYPE (obj
))
1254 /* A string may have text properties, which can be circular. */
1255 traverse_intervals_noorder (STRING_INTERVALS (obj
),
1256 print_preprocess_string
, Qnil
);
1260 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1261 just as in print_object. */
1262 if (loop_count
&& EQ (obj
, halftail
))
1264 print_preprocess (XCAR (obj
));
1267 if (!(loop_count
& 1))
1268 halftail
= XCDR (halftail
);
1271 case Lisp_Vectorlike
:
1272 size
= XVECTOR (obj
)->size
;
1273 if (size
& PSEUDOVECTOR_FLAG
)
1274 size
&= PSEUDOVECTOR_SIZE_MASK
;
1275 for (i
= 0; i
< size
; i
++)
1276 print_preprocess (XVECTOR (obj
)->contents
[i
]);
1277 if (HASH_TABLE_P (obj
))
1278 { /* For hash tables, the key_and_value slot is past
1279 `size' because it needs to be marked specially in case
1280 the table is weak. */
1281 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1282 print_preprocess (h
->key_and_value
);
1294 print_preprocess_string (INTERVAL interval
, Lisp_Object arg
)
1296 print_preprocess (interval
->plist
);
1299 static void print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
);
1301 #define PRINT_STRING_NON_CHARSET_FOUND 1
1302 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1304 /* Bitwise or of the above macros. */
1305 static int print_check_string_result
;
1308 print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
)
1312 if (NILP (interval
->plist
)
1313 || (print_check_string_result
== (PRINT_STRING_NON_CHARSET_FOUND
1314 | PRINT_STRING_UNSAFE_CHARSET_FOUND
)))
1316 for (val
= interval
->plist
; CONSP (val
) && ! EQ (XCAR (val
), Qcharset
);
1317 val
= XCDR (XCDR (val
)));
1320 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1323 if (! (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
))
1325 if (! EQ (val
, interval
->plist
)
1326 || CONSP (XCDR (XCDR (val
))))
1327 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1329 if (NILP (Vprint_charset_text_property
)
1330 || ! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1333 EMACS_INT charpos
= interval
->position
;
1334 EMACS_INT bytepos
= string_char_to_byte (string
, charpos
);
1335 Lisp_Object charset
;
1337 charset
= XCAR (XCDR (val
));
1338 for (i
= 0; i
< LENGTH (interval
); i
++)
1340 FETCH_STRING_CHAR_ADVANCE (c
, string
, charpos
, bytepos
);
1341 if (! ASCII_CHAR_P (c
)
1342 && ! EQ (CHARSET_NAME (CHAR_CHARSET (c
)), charset
))
1344 print_check_string_result
|= PRINT_STRING_UNSAFE_CHARSET_FOUND
;
1351 /* The value is (charset . nil). */
1352 static Lisp_Object print_prune_charset_plist
;
1355 print_prune_string_charset (Lisp_Object string
)
1357 print_check_string_result
= 0;
1358 traverse_intervals (STRING_INTERVALS (string
), 0,
1359 print_check_string_charset_prop
, string
);
1360 if (! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1362 string
= Fcopy_sequence (string
);
1363 if (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
)
1365 if (NILP (print_prune_charset_plist
))
1366 print_prune_charset_plist
= Fcons (Qcharset
, Qnil
);
1367 Fremove_text_properties (make_number (0),
1368 make_number (SCHARS (string
)),
1369 print_prune_charset_plist
, string
);
1372 Fset_text_properties (make_number (0), make_number (SCHARS (string
)),
1379 print_object (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
)
1385 /* See similar code in print_preprocess. */
1386 if (print_depth
>= PRINT_CIRCLE
)
1387 error ("Apparently circular structure being printed");
1389 /* Detect circularities and truncate them. */
1390 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1391 || FUNVECP (obj
) || CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
)
1392 || HASH_TABLE_P (obj
)
1393 || (! NILP (Vprint_gensym
)
1395 && !SYMBOL_INTERNED_P (obj
)))
1397 if (NILP (Vprint_circle
) && NILP (Vprint_gensym
))
1399 /* Simple but incomplete way. */
1401 for (i
= 0; i
< print_depth
; i
++)
1402 if (EQ (obj
, being_printed
[i
]))
1404 sprintf (buf
, "#%d", i
);
1405 strout (buf
, -1, -1, printcharfun
, 0);
1408 being_printed
[print_depth
] = obj
;
1412 /* With the print-circle feature. */
1413 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1418 { /* Add a prefix #n= if OBJ has not yet been printed;
1419 that is, its status field is nil. */
1420 sprintf (buf
, "#%d=", -n
);
1421 strout (buf
, -1, -1, printcharfun
, 0);
1422 /* OBJ is going to be printed. Remember that fact. */
1423 Fputhash (obj
, make_number (- n
), Vprint_number_table
);
1427 /* Just print #n# if OBJ has already been printed. */
1428 sprintf (buf
, "#%d#", n
);
1429 strout (buf
, -1, -1, printcharfun
, 0);
1438 switch (XTYPE (obj
))
1441 if (sizeof (int) == sizeof (EMACS_INT
))
1442 sprintf (buf
, "%d", (int) XINT (obj
));
1443 else if (sizeof (long) == sizeof (EMACS_INT
))
1444 sprintf (buf
, "%ld", (long) XINT (obj
));
1447 strout (buf
, -1, -1, printcharfun
, 0);
1452 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
1454 float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1455 strout (pigbuf
, -1, -1, printcharfun
, 0);
1461 print_string (obj
, printcharfun
);
1464 register EMACS_INT i
, i_byte
;
1465 struct gcpro gcpro1
;
1467 EMACS_INT size_byte
;
1468 /* 1 means we must ensure that the next character we output
1469 cannot be taken as part of a hex character escape. */
1470 int need_nonhex
= 0;
1471 int multibyte
= STRING_MULTIBYTE (obj
);
1475 if (! EQ (Vprint_charset_text_property
, Qt
))
1476 obj
= print_prune_string_charset (obj
);
1478 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1486 size_byte
= SBYTES (obj
);
1488 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1490 /* Here, we must convert each multi-byte form to the
1491 corresponding character code before handing it to PRINTCHAR. */
1497 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
, len
);
1505 if (c
== '\n' && print_escape_newlines
)
1510 else if (c
== '\f' && print_escape_newlines
)
1516 && (CHAR_BYTE8_P (c
)
1517 || (! ASCII_CHAR_P (c
) && print_escape_multibyte
)))
1519 /* When multibyte is disabled,
1520 print multibyte string chars using hex escapes.
1521 For a char code that could be in a unibyte string,
1522 when found in a multibyte string, always use a hex escape
1523 so it reads back as multibyte. */
1526 if (CHAR_BYTE8_P (c
))
1527 sprintf (outbuf
, "\\%03o", CHAR_TO_BYTE8 (c
));
1530 sprintf (outbuf
, "\\x%04x", c
);
1533 strout (outbuf
, -1, -1, printcharfun
, 0);
1535 else if (! multibyte
1536 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1537 && print_escape_nonascii
)
1539 /* When printing in a multibyte buffer
1540 or when explicitly requested,
1541 print single-byte non-ASCII string chars
1542 using octal escapes. */
1544 sprintf (outbuf
, "\\%03o", c
);
1545 strout (outbuf
, -1, -1, printcharfun
, 0);
1549 /* If we just had a hex escape, and this character
1550 could be taken as part of it,
1551 output `\ ' to prevent that. */
1555 if ((c
>= 'a' && c
<= 'f')
1556 || (c
>= 'A' && c
<= 'F')
1557 || (c
>= '0' && c
<= '9'))
1558 strout ("\\ ", -1, -1, printcharfun
, 0);
1561 if (c
== '\"' || c
== '\\')
1568 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1570 traverse_intervals (STRING_INTERVALS (obj
),
1571 0, print_interval
, printcharfun
);
1581 register int confusing
;
1582 register unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1583 register unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1586 EMACS_INT size_byte
;
1589 name
= SYMBOL_NAME (obj
);
1591 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1594 /* If symbol name begins with a digit, and ends with a digit,
1595 and contains nothing but digits and `e', it could be treated
1596 as a number. So set CONFUSING.
1598 Symbols that contain periods could also be taken as numbers,
1599 but periods are always escaped, so we don't have to worry
1601 else if (*p
>= '0' && *p
<= '9'
1602 && end
[-1] >= '0' && end
[-1] <= '9')
1604 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1605 /* Needed for \2e10. */
1606 || *p
== 'e' || *p
== 'E'))
1608 confusing
= (end
== p
);
1613 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1619 size_byte
= SBYTES (name
);
1621 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1623 /* Here, we must convert each multi-byte form to the
1624 corresponding character code before handing it to PRINTCHAR. */
1625 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1630 if (c
== '\"' || c
== '\\' || c
== '\''
1631 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1632 || c
== ',' || c
=='.' || c
== '`'
1633 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1635 PRINTCHAR ('\\'), confusing
= 0;
1643 /* If deeper than spec'd depth, print placeholder. */
1644 if (INTEGERP (Vprint_level
)
1645 && print_depth
> XINT (Vprint_level
))
1646 strout ("...", -1, -1, printcharfun
, 0);
1647 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1648 && (EQ (XCAR (obj
), Qquote
)))
1651 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1653 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1654 && (EQ (XCAR (obj
), Qfunction
)))
1658 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1660 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1661 && ((EQ (XCAR (obj
), Qbackquote
))))
1663 print_object (XCAR (obj
), printcharfun
, 0);
1664 new_backquote_output
++;
1665 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1666 new_backquote_output
--;
1668 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1669 && new_backquote_output
1670 && ((EQ (XCAR (obj
), Qbackquote
)
1671 || EQ (XCAR (obj
), Qcomma
)
1672 || EQ (XCAR (obj
), Qcomma_at
)
1673 || EQ (XCAR (obj
), Qcomma_dot
))))
1675 print_object (XCAR (obj
), printcharfun
, 0);
1676 new_backquote_output
--;
1677 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1678 new_backquote_output
++;
1684 /* If the first element is a backquote form,
1685 print it old-style so it won't be misunderstood. */
1686 if (print_quoted
&& CONSP (XCAR (obj
))
1687 && CONSP (XCDR (XCAR (obj
)))
1688 && NILP (XCDR (XCDR (XCAR (obj
))))
1689 && EQ (XCAR (XCAR (obj
)), Qbackquote
))
1695 print_object (Qbackquote
, printcharfun
, 0);
1698 print_object (XCAR (XCDR (tem
)), printcharfun
, 0);
1705 EMACS_INT print_length
;
1707 Lisp_Object halftail
= obj
;
1709 /* Negative values of print-length are invalid in CL.
1710 Treat them like nil, as CMUCL does. */
1711 if (NATNUMP (Vprint_length
))
1712 print_length
= XFASTINT (Vprint_length
);
1719 /* Detect circular list. */
1720 if (NILP (Vprint_circle
))
1722 /* Simple but imcomplete way. */
1723 if (i
!= 0 && EQ (obj
, halftail
))
1725 sprintf (buf
, " . #%d", i
/ 2);
1726 strout (buf
, -1, -1, printcharfun
, 0);
1732 /* With the print-circle feature. */
1735 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1738 strout (" . ", 3, 3, printcharfun
, 0);
1739 print_object (obj
, printcharfun
, escapeflag
);
1748 if (print_length
&& i
> print_length
)
1750 strout ("...", 3, 3, printcharfun
, 0);
1754 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1758 halftail
= XCDR (halftail
);
1762 /* OBJ non-nil here means it's the end of a dotted list. */
1765 strout (" . ", 3, 3, printcharfun
, 0);
1766 print_object (obj
, printcharfun
, escapeflag
);
1774 case Lisp_Vectorlike
:
1779 strout ("#<process ", -1, -1, printcharfun
, 0);
1780 print_string (XPROCESS (obj
)->name
, printcharfun
);
1784 print_string (XPROCESS (obj
)->name
, printcharfun
);
1786 else if (BOOL_VECTOR_P (obj
))
1789 register unsigned char c
;
1790 struct gcpro gcpro1
;
1791 EMACS_INT size_in_chars
1792 = ((XBOOL_VECTOR (obj
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
1793 / BOOL_VECTOR_BITS_PER_CHAR
);
1799 sprintf (buf
, "%ld", (long) XBOOL_VECTOR (obj
)->size
);
1800 strout (buf
, -1, -1, printcharfun
, 0);
1803 /* Don't print more characters than the specified maximum.
1804 Negative values of print-length are invalid. Treat them
1805 like a print-length of nil. */
1806 if (NATNUMP (Vprint_length
)
1807 && XFASTINT (Vprint_length
) < size_in_chars
)
1808 size_in_chars
= XFASTINT (Vprint_length
);
1810 for (i
= 0; i
< size_in_chars
; i
++)
1813 c
= XBOOL_VECTOR (obj
)->data
[i
];
1814 if (c
== '\n' && print_escape_newlines
)
1819 else if (c
== '\f' && print_escape_newlines
)
1824 else if (c
> '\177')
1826 /* Use octal escapes to avoid encoding issues. */
1828 PRINTCHAR ('0' + ((c
>> 6) & 3));
1829 PRINTCHAR ('0' + ((c
>> 3) & 7));
1830 PRINTCHAR ('0' + (c
& 7));
1834 if (c
== '\"' || c
== '\\')
1843 else if (SUBRP (obj
))
1845 strout ("#<subr ", -1, -1, printcharfun
, 0);
1846 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
, 0);
1849 else if (WINDOWP (obj
))
1851 strout ("#<window ", -1, -1, printcharfun
, 0);
1852 sprintf (buf
, "%ld", (long) XFASTINT (XWINDOW (obj
)->sequence_number
));
1853 strout (buf
, -1, -1, printcharfun
, 0);
1854 if (!NILP (XWINDOW (obj
)->buffer
))
1856 strout (" on ", -1, -1, printcharfun
, 0);
1857 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1861 else if (TERMINALP (obj
))
1863 struct terminal
*t
= XTERMINAL (obj
);
1864 strout ("#<terminal ", -1, -1, printcharfun
, 0);
1865 sprintf (buf
, "%d", t
->id
);
1866 strout (buf
, -1, -1, printcharfun
, 0);
1869 strout (" on ", -1, -1, printcharfun
, 0);
1870 strout (t
->name
, -1, -1, printcharfun
, 0);
1874 else if (HASH_TABLE_P (obj
))
1876 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1878 EMACS_INT real_size
, size
;
1880 strout ("#<hash-table", -1, -1, printcharfun
, 0);
1881 if (SYMBOLP (h
->test
))
1885 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
, 0);
1887 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
, 0);
1889 sprintf (buf
, "%ld/%ld", (long) h
->count
,
1890 (long) XVECTOR (h
->next
)->size
);
1891 strout (buf
, -1, -1, printcharfun
, 0);
1893 sprintf (buf
, " 0x%lx", (unsigned long) h
);
1894 strout (buf
, -1, -1, printcharfun
, 0);
1897 /* Implement a readable output, e.g.:
1898 #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
1899 /* Always print the size. */
1900 sprintf (buf
, "#s(hash-table size %ld",
1901 (long) XVECTOR (h
->next
)->size
);
1902 strout (buf
, -1, -1, printcharfun
, 0);
1904 if (!NILP (h
->test
))
1906 strout (" test ", -1, -1, printcharfun
, 0);
1907 print_object (h
->test
, printcharfun
, 0);
1910 if (!NILP (h
->weak
))
1912 strout (" weakness ", -1, -1, printcharfun
, 0);
1913 print_object (h
->weak
, printcharfun
, 0);
1916 if (!NILP (h
->rehash_size
))
1918 strout (" rehash-size ", -1, -1, printcharfun
, 0);
1919 print_object (h
->rehash_size
, printcharfun
, 0);
1922 if (!NILP (h
->rehash_threshold
))
1924 strout (" rehash-threshold ", -1, -1, printcharfun
, 0);
1925 print_object (h
->rehash_threshold
, printcharfun
, 0);
1928 strout (" data ", -1, -1, printcharfun
, 0);
1930 /* Print the data here as a plist. */
1931 real_size
= HASH_TABLE_SIZE (h
);
1934 /* Don't print more elements than the specified maximum. */
1935 if (NATNUMP (Vprint_length
)
1936 && XFASTINT (Vprint_length
) < size
)
1937 size
= XFASTINT (Vprint_length
);
1940 for (i
= 0; i
< size
; i
++)
1941 if (!NILP (HASH_HASH (h
, i
)))
1943 if (i
) PRINTCHAR (' ');
1944 print_object (HASH_KEY (h
, i
), printcharfun
, 1);
1946 print_object (HASH_VALUE (h
, i
), printcharfun
, 1);
1949 if (size
< real_size
)
1950 strout (" ...", 4, 4, printcharfun
, 0);
1956 else if (BUFFERP (obj
))
1958 if (NILP (XBUFFER (obj
)->name
))
1959 strout ("#<killed buffer>", -1, -1, printcharfun
, 0);
1960 else if (escapeflag
)
1962 strout ("#<buffer ", -1, -1, printcharfun
, 0);
1963 print_string (XBUFFER (obj
)->name
, printcharfun
);
1967 print_string (XBUFFER (obj
)->name
, printcharfun
);
1969 else if (WINDOW_CONFIGURATIONP (obj
))
1971 strout ("#<window-configuration>", -1, -1, printcharfun
, 0);
1973 else if (FRAMEP (obj
))
1975 strout ((FRAME_LIVE_P (XFRAME (obj
))
1976 ? "#<frame " : "#<dead frame "),
1977 -1, -1, printcharfun
, 0);
1978 print_string (XFRAME (obj
)->name
, printcharfun
);
1979 sprintf (buf
, " 0x%lx", (unsigned long) (XFRAME (obj
)));
1980 strout (buf
, -1, -1, printcharfun
, 0);
1983 else if (FONTP (obj
))
1987 if (! FONT_OBJECT_P (obj
))
1989 if (FONT_SPEC_P (obj
))
1990 strout ("#<font-spec", -1, -1, printcharfun
, 0);
1992 strout ("#<font-entity", -1, -1, printcharfun
, 0);
1993 for (i
= 0; i
< FONT_SPEC_MAX
; i
++)
1996 if (i
< FONT_WEIGHT_INDEX
|| i
> FONT_WIDTH_INDEX
)
1997 print_object (AREF (obj
, i
), printcharfun
, escapeflag
);
1999 print_object (font_style_symbolic (obj
, i
, 0),
2000 printcharfun
, escapeflag
);
2005 strout ("#<font-object ", -1, -1, printcharfun
, 0);
2006 print_object (AREF (obj
, FONT_NAME_INDEX
), printcharfun
,
2013 EMACS_INT size
= XVECTOR (obj
)->size
;
2017 size
&= PSEUDOVECTOR_SIZE_MASK
;
2019 if (CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
))
2021 /* We print a char-table as if it were a vector,
2022 lumping the parent and default slots in with the
2023 character slots. But we add #^ as a prefix. */
2025 /* Make each lowest sub_char_table start a new line.
2026 Otherwise we'll make a line extremely long, which
2027 results in slow redisplay. */
2028 if (SUB_CHAR_TABLE_P (obj
)
2029 && XINT (XSUB_CHAR_TABLE (obj
)->depth
) == 3)
2033 if (SUB_CHAR_TABLE_P (obj
))
2035 size
&= PSEUDOVECTOR_SIZE_MASK
;
2037 if (size
& PSEUDOVECTOR_FLAG
)
2043 register Lisp_Object tem
;
2044 EMACS_INT real_size
= size
;
2046 /* Don't print more elements than the specified maximum. */
2047 if (NATNUMP (Vprint_length
)
2048 && XFASTINT (Vprint_length
) < size
)
2049 size
= XFASTINT (Vprint_length
);
2051 for (i
= 0; i
< size
; i
++)
2053 if (i
) PRINTCHAR (' ');
2054 tem
= XVECTOR (obj
)->contents
[i
];
2055 print_object (tem
, printcharfun
, escapeflag
);
2057 if (size
< real_size
)
2058 strout (" ...", 4, 4, printcharfun
, 0);
2065 switch (XMISCTYPE (obj
))
2067 case Lisp_Misc_Marker
:
2068 strout ("#<marker ", -1, -1, printcharfun
, 0);
2069 /* Do you think this is necessary? */
2070 if (XMARKER (obj
)->insertion_type
!= 0)
2071 strout ("(moves after insertion) ", -1, -1, printcharfun
, 0);
2072 if (! XMARKER (obj
)->buffer
)
2073 strout ("in no buffer", -1, -1, printcharfun
, 0);
2076 sprintf (buf
, "at %ld", (long)marker_position (obj
));
2077 strout (buf
, -1, -1, printcharfun
, 0);
2078 strout (" in ", -1, -1, printcharfun
, 0);
2079 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
2084 case Lisp_Misc_Overlay
:
2085 strout ("#<overlay ", -1, -1, printcharfun
, 0);
2086 if (! XMARKER (OVERLAY_START (obj
))->buffer
)
2087 strout ("in no buffer", -1, -1, printcharfun
, 0);
2090 sprintf (buf
, "from %ld to %ld in ",
2091 (long)marker_position (OVERLAY_START (obj
)),
2092 (long)marker_position (OVERLAY_END (obj
)));
2093 strout (buf
, -1, -1, printcharfun
, 0);
2094 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
2100 /* Remaining cases shouldn't happen in normal usage, but let's print
2101 them anyway for the benefit of the debugger. */
2102 case Lisp_Misc_Free
:
2103 strout ("#<misc free cell>", -1, -1, printcharfun
, 0);
2106 case Lisp_Misc_Save_Value
:
2107 strout ("#<save_value ", -1, -1, printcharfun
, 0);
2108 sprintf(buf
, "ptr=0x%08lx int=%d",
2109 (unsigned long) XSAVE_VALUE (obj
)->pointer
,
2110 XSAVE_VALUE (obj
)->integer
);
2111 strout (buf
, -1, -1, printcharfun
, 0);
2123 /* We're in trouble if this happens!
2124 Probably should just abort () */
2125 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
, 0);
2127 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2128 else if (VECTORLIKEP (obj
))
2129 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
2131 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2132 strout (buf
, -1, -1, printcharfun
, 0);
2133 strout (" Save your buffers immediately and please report this bug>",
2134 -1, -1, printcharfun
, 0);
2142 /* Print a description of INTERVAL using PRINTCHARFUN.
2143 This is part of printing a string that has text properties. */
2146 print_interval (INTERVAL interval
, Lisp_Object printcharfun
)
2148 if (NILP (interval
->plist
))
2151 print_object (make_number (interval
->position
), printcharfun
, 1);
2153 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2156 print_object (interval
->plist
, printcharfun
, 1);
2161 syms_of_print (void)
2163 Qtemp_buffer_setup_hook
= intern_c_string ("temp-buffer-setup-hook");
2164 staticpro (&Qtemp_buffer_setup_hook
);
2166 DEFVAR_LISP ("standard-output", Vstandard_output
,
2167 doc
: /* Output stream `print' uses by default for outputting a character.
2168 This may be any function of one argument.
2169 It may also be a buffer (output is inserted before point)
2170 or a marker (output is inserted and the marker is advanced)
2171 or the symbol t (output appears in the echo area). */);
2172 Vstandard_output
= Qt
;
2173 Qstandard_output
= intern_c_string ("standard-output");
2174 staticpro (&Qstandard_output
);
2176 DEFVAR_LISP ("float-output-format", Vfloat_output_format
,
2177 doc
: /* The format descriptor string used to print floats.
2178 This is a %-spec like those accepted by `printf' in C,
2179 but with some restrictions. It must start with the two characters `%.'.
2180 After that comes an integer precision specification,
2181 and then a letter which controls the format.
2182 The letters allowed are `e', `f' and `g'.
2183 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2184 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2185 Use `g' to choose the shorter of those two formats for the number at hand.
2186 The precision in any of these cases is the number of digits following
2187 the decimal point. With `f', a precision of 0 means to omit the
2188 decimal point. 0 is not allowed with `e' or `g'.
2190 A value of nil means to use the shortest notation
2191 that represents the number without losing information. */);
2192 Vfloat_output_format
= Qnil
;
2193 Qfloat_output_format
= intern_c_string ("float-output-format");
2194 staticpro (&Qfloat_output_format
);
2196 DEFVAR_LISP ("print-length", Vprint_length
,
2197 doc
: /* Maximum length of list to print before abbreviating.
2198 A value of nil means no limit. See also `eval-expression-print-length'. */);
2199 Vprint_length
= Qnil
;
2201 DEFVAR_LISP ("print-level", Vprint_level
,
2202 doc
: /* Maximum depth of list nesting to print before abbreviating.
2203 A value of nil means no limit. See also `eval-expression-print-level'. */);
2204 Vprint_level
= Qnil
;
2206 DEFVAR_BOOL ("print-escape-newlines", print_escape_newlines
,
2207 doc
: /* Non-nil means print newlines in strings as `\\n'.
2208 Also print formfeeds as `\\f'. */);
2209 print_escape_newlines
= 0;
2211 DEFVAR_BOOL ("print-escape-nonascii", print_escape_nonascii
,
2212 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2213 \(OOO is the octal representation of the character code.)
2214 Only single-byte characters are affected, and only in `prin1'.
2215 When the output goes in a multibyte buffer, this feature is
2216 enabled regardless of the value of the variable. */);
2217 print_escape_nonascii
= 0;
2219 DEFVAR_BOOL ("print-escape-multibyte", print_escape_multibyte
,
2220 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2221 \(XXXX is the hex representation of the character code.)
2222 This affects only `prin1'. */);
2223 print_escape_multibyte
= 0;
2225 DEFVAR_BOOL ("print-quoted", print_quoted
,
2226 doc
: /* Non-nil means print quoted forms with reader syntax.
2227 I.e., (quote foo) prints as 'foo, (function foo) as #'foo. */);
2230 DEFVAR_LISP ("print-gensym", Vprint_gensym
,
2231 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2232 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2233 When the uninterned symbol appears within a recursive data structure,
2234 and the symbol appears more than once, in addition use the #N# and #N=
2235 constructs as needed, so that multiple references to the same symbol are
2236 shared once again when the text is read back. */);
2237 Vprint_gensym
= Qnil
;
2239 DEFVAR_LISP ("print-circle", Vprint_circle
,
2240 doc
: /* *Non-nil means print recursive structures using #N= and #N# syntax.
2241 If nil, printing proceeds recursively and may lead to
2242 `max-lisp-eval-depth' being exceeded or an error may occur:
2243 \"Apparently circular structure being printed.\" Also see
2244 `print-length' and `print-level'.
2245 If non-nil, shared substructures anywhere in the structure are printed
2246 with `#N=' before the first occurrence (in the order of the print
2247 representation) and `#N#' in place of each subsequent occurrence,
2248 where N is a positive decimal integer. */);
2249 Vprint_circle
= Qnil
;
2251 DEFVAR_LISP ("print-continuous-numbering", Vprint_continuous_numbering
,
2252 doc
: /* *Non-nil means number continuously across print calls.
2253 This affects the numbers printed for #N= labels and #M# references.
2254 See also `print-circle', `print-gensym', and `print-number-table'.
2255 This variable should not be set with `setq'; bind it with a `let' instead. */);
2256 Vprint_continuous_numbering
= Qnil
;
2258 DEFVAR_LISP ("print-number-table", Vprint_number_table
,
2259 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2260 The Lisp printer uses this vector to detect Lisp objects referenced more
2263 When you bind `print-continuous-numbering' to t, you should probably
2264 also bind `print-number-table' to nil. This ensures that the value of
2265 `print-number-table' can be garbage-collected once the printing is
2266 done. If all elements of `print-number-table' are nil, it means that
2267 the printing done so far has not found any shared structure or objects
2268 that need to be recorded in the table. */);
2269 Vprint_number_table
= Qnil
;
2271 DEFVAR_LISP ("print-charset-text-property", Vprint_charset_text_property
,
2272 doc
: /* A flag to control printing of `charset' text property on printing a string.
2273 The value must be nil, t, or `default'.
2275 If the value is nil, don't print the text property `charset'.
2277 If the value is t, always print the text property `charset'.
2279 If the value is `default', print the text property `charset' only when
2280 the value is different from what is guessed in the current charset
2282 Vprint_charset_text_property
= Qdefault
;
2284 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2285 staticpro (&Vprin1_to_string_buffer
);
2288 defsubr (&Sprin1_to_string
);
2289 defsubr (&Serror_message_string
);
2293 defsubr (&Swrite_char
);
2294 defsubr (&Sexternal_debugging_output
);
2295 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2296 defsubr (&Sredirect_debugging_output
);
2299 Qexternal_debugging_output
= intern_c_string ("external-debugging-output");
2300 staticpro (&Qexternal_debugging_output
);
2302 Qprint_escape_newlines
= intern_c_string ("print-escape-newlines");
2303 staticpro (&Qprint_escape_newlines
);
2305 Qprint_escape_multibyte
= intern_c_string ("print-escape-multibyte");
2306 staticpro (&Qprint_escape_multibyte
);
2308 Qprint_escape_nonascii
= intern_c_string ("print-escape-nonascii");
2309 staticpro (&Qprint_escape_nonascii
);
2311 print_prune_charset_plist
= Qnil
;
2312 staticpro (&print_prune_charset_plist
);
2314 defsubr (&Swith_output_to_temp_buffer
);