1 /* Lisp object printing and output streams.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997,
3 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006, 2007, 2008, 2009, 2010, 2011 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 Vstandard_output
, Qstandard_output
;
42 Lisp_Object Qtemp_buffer_setup_hook
;
44 /* These are used to print like we read. */
46 Lisp_Object Vfloat_output_format
, 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 /* Maximum length of list to print in full; noninteger means
82 effectively infinity */
84 Lisp_Object Vprint_length
;
86 /* Maximum depth of list to print in full; noninteger means
87 effectively infinity. */
89 Lisp_Object Vprint_level
;
91 /* Nonzero means print newlines in strings as \n. */
93 int print_escape_newlines
;
95 /* Nonzero means to print single-byte non-ascii characters in strings as
98 int print_escape_nonascii
;
100 /* Nonzero means to print multibyte characters in strings as hex escapes. */
102 int print_escape_multibyte
;
104 Lisp_Object Qprint_escape_newlines
;
105 Lisp_Object Qprint_escape_multibyte
, Qprint_escape_nonascii
;
107 /* Nonzero means print (quote foo) forms as 'foo, etc. */
111 /* Non-nil means print #: before uninterned symbols. */
113 Lisp_Object Vprint_gensym
;
115 /* Non-nil means print recursive structures using #n= and #n# syntax. */
117 Lisp_Object Vprint_circle
;
119 /* Non-nil means keep continuous number for #n= and #n# syntax
120 between several print functions. */
122 Lisp_Object Vprint_continuous_numbering
;
124 /* Vprint_number_table is a table, that keeps objects that are going to
125 be printed, to allow use of #n= and #n# to express sharing.
126 For any given object, the table can give the following values:
127 t the object will be printed only once.
128 -N the object will be printed several times and will take number N.
129 N the object has been printed so we can refer to it as #N#.
130 print_number_index holds the largest N already used.
131 N has to be striclty larger than 0 since we need to distinguish -N. */
132 int print_number_index
;
133 Lisp_Object Vprint_number_table
;
135 void print_interval (INTERVAL interval
, Lisp_Object printcharfun
);
137 /* GDB resets this to zero on W32 to disable OutputDebugString calls. */
138 int print_output_debug_flag EXTERNALLY_VISIBLE
= 1;
141 /* Low level output routines for characters and strings */
143 /* Lisp functions to do output using a stream
144 must have the stream in a variable called printcharfun
145 and must start with PRINTPREPARE, end with PRINTFINISH,
146 and use PRINTDECLARE to declare common variables.
147 Use PRINTCHAR to output one character,
148 or call strout to output a block of characters. */
150 #define PRINTDECLARE \
151 struct buffer *old = current_buffer; \
152 EMACS_INT old_point = -1, start_point = -1; \
153 EMACS_INT old_point_byte = -1, start_point_byte = -1; \
154 int specpdl_count = SPECPDL_INDEX (); \
155 int free_print_buffer = 0; \
156 int multibyte = !NILP (current_buffer->enable_multibyte_characters); \
159 #define PRINTPREPARE \
160 original = printcharfun; \
161 if (NILP (printcharfun)) printcharfun = Qt; \
162 if (BUFFERP (printcharfun)) \
164 if (XBUFFER (printcharfun) != current_buffer) \
165 Fset_buffer (printcharfun); \
166 printcharfun = Qnil; \
168 if (MARKERP (printcharfun)) \
170 EMACS_INT marker_pos; \
171 if (! XMARKER (printcharfun)->buffer) \
172 error ("Marker does not point anywhere"); \
173 if (XMARKER (printcharfun)->buffer != current_buffer) \
174 set_buffer_internal (XMARKER (printcharfun)->buffer); \
175 marker_pos = marker_position (printcharfun); \
176 if (marker_pos < BEGV || marker_pos > ZV) \
177 error ("Marker is outside the accessible part of the buffer"); \
179 old_point_byte = PT_BYTE; \
180 SET_PT_BOTH (marker_pos, \
181 marker_byte_position (printcharfun)); \
183 start_point_byte = PT_BYTE; \
184 printcharfun = Qnil; \
186 if (NILP (printcharfun)) \
188 Lisp_Object string; \
189 if (NILP (current_buffer->enable_multibyte_characters) \
190 && ! print_escape_multibyte) \
191 specbind (Qprint_escape_multibyte, Qt); \
192 if (! NILP (current_buffer->enable_multibyte_characters) \
193 && ! print_escape_nonascii) \
194 specbind (Qprint_escape_nonascii, Qt); \
195 if (print_buffer != 0) \
197 string = make_string_from_bytes (print_buffer, \
199 print_buffer_pos_byte); \
200 record_unwind_protect (print_unwind, string); \
204 print_buffer_size = 1000; \
205 print_buffer = (char *) xmalloc (print_buffer_size); \
206 free_print_buffer = 1; \
208 print_buffer_pos = 0; \
209 print_buffer_pos_byte = 0; \
211 if (EQ (printcharfun, Qt) && ! noninteractive) \
212 setup_echo_area_for_printing (multibyte);
214 #define PRINTFINISH \
215 if (NILP (printcharfun)) \
217 if (print_buffer_pos != print_buffer_pos_byte \
218 && NILP (current_buffer->enable_multibyte_characters)) \
220 unsigned char *temp \
221 = (unsigned char *) alloca (print_buffer_pos + 1); \
222 copy_text (print_buffer, temp, print_buffer_pos_byte, \
224 insert_1_both (temp, print_buffer_pos, \
225 print_buffer_pos, 0, 1, 0); \
228 insert_1_both (print_buffer, print_buffer_pos, \
229 print_buffer_pos_byte, 0, 1, 0); \
230 signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
232 if (free_print_buffer) \
234 xfree (print_buffer); \
237 unbind_to (specpdl_count, Qnil); \
238 if (MARKERP (original)) \
239 set_marker_both (original, Qnil, PT, PT_BYTE); \
240 if (old_point >= 0) \
241 SET_PT_BOTH (old_point + (old_point >= start_point \
242 ? PT - start_point : 0), \
243 old_point_byte + (old_point_byte >= start_point_byte \
244 ? PT_BYTE - start_point_byte : 0)); \
245 if (old != current_buffer) \
246 set_buffer_internal (old);
248 #define PRINTCHAR(ch) printchar (ch, printcharfun)
250 /* This is used to restore the saved contents of print_buffer
251 when there is a recursive call to print. */
254 print_unwind (Lisp_Object saved_text
)
256 memcpy (print_buffer
, SDATA (saved_text
), SCHARS (saved_text
));
261 /* Print character CH using method FUN. FUN nil means print to
262 print_buffer. FUN t means print to echo area or stdout if
263 non-interactive. If FUN is neither nil nor t, call FUN with CH as
267 printchar (unsigned int ch
, Lisp_Object fun
)
269 if (!NILP (fun
) && !EQ (fun
, Qt
))
270 call1 (fun
, make_number (ch
));
273 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
274 int len
= CHAR_STRING (ch
, str
);
280 if (print_buffer_pos_byte
+ len
>= print_buffer_size
)
281 print_buffer
= (char *) xrealloc (print_buffer
,
282 print_buffer_size
*= 2);
283 memcpy (print_buffer
+ print_buffer_pos_byte
, str
, len
);
284 print_buffer_pos
+= 1;
285 print_buffer_pos_byte
+= len
;
287 else if (noninteractive
)
289 fwrite (str
, 1, len
, stdout
);
290 noninteractive_need_newline
= 1;
295 = !NILP (current_buffer
->enable_multibyte_characters
);
297 setup_echo_area_for_printing (multibyte_p
);
299 message_dolog (str
, len
, 0, multibyte_p
);
305 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
306 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
307 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
308 print_buffer. PRINTCHARFUN t means output to the echo area or to
309 stdout if non-interactive. If neither nil nor t, call Lisp
310 function PRINTCHARFUN for each character printed. MULTIBYTE
311 non-zero means PTR contains multibyte characters.
313 In the case where PRINTCHARFUN is nil, it is safe for PTR to point
314 to data in a Lisp string. Otherwise that is not safe. */
317 strout (const char *ptr
, EMACS_INT size
, EMACS_INT size_byte
,
318 Lisp_Object printcharfun
, int multibyte
)
321 size_byte
= size
= strlen (ptr
);
323 if (NILP (printcharfun
))
325 if (print_buffer_pos_byte
+ size_byte
> print_buffer_size
)
327 print_buffer_size
= print_buffer_size
* 2 + size_byte
;
328 print_buffer
= (char *) xrealloc (print_buffer
,
331 memcpy (print_buffer
+ print_buffer_pos_byte
, ptr
, size_byte
);
332 print_buffer_pos
+= size
;
333 print_buffer_pos_byte
+= size_byte
;
335 else if (noninteractive
&& EQ (printcharfun
, Qt
))
337 fwrite (ptr
, 1, size_byte
, stdout
);
338 noninteractive_need_newline
= 1;
340 else if (EQ (printcharfun
, Qt
))
342 /* Output to echo area. We're trying to avoid a little overhead
343 here, that's the reason we don't call printchar to do the
347 = !NILP (current_buffer
->enable_multibyte_characters
);
349 setup_echo_area_for_printing (multibyte_p
);
350 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
352 if (size
== size_byte
)
354 for (i
= 0; i
< size
; ++i
)
355 insert_char ((unsigned char) *ptr
++);
360 for (i
= 0; i
< size_byte
; i
+= len
)
362 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, len
);
369 /* PRINTCHARFUN is a Lisp function. */
372 if (size
== size_byte
)
374 while (i
< size_byte
)
382 while (i
< size_byte
)
384 /* Here, we must convert each multi-byte form to the
385 corresponding character code before handing it to
388 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, len
);
396 /* Print the contents of a string STRING using PRINTCHARFUN.
397 It isn't safe to use strout in many cases,
398 because printing one char can relocate. */
401 print_string (Lisp_Object string
, Lisp_Object printcharfun
)
403 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
407 if (print_escape_nonascii
)
408 string
= string_escape_byte8 (string
);
410 if (STRING_MULTIBYTE (string
))
411 chars
= SCHARS (string
);
412 else if (! print_escape_nonascii
413 && (EQ (printcharfun
, Qt
)
414 ? ! NILP (buffer_defaults
.enable_multibyte_characters
)
415 : ! NILP (current_buffer
->enable_multibyte_characters
)))
417 /* If unibyte string STRING contains 8-bit codes, we must
418 convert STRING to a multibyte string containing the same
423 chars
= SBYTES (string
);
424 bytes
= parse_str_to_multibyte (SDATA (string
), chars
);
427 newstr
= make_uninit_multibyte_string (chars
, bytes
);
428 memcpy (SDATA (newstr
), SDATA (string
), chars
);
429 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
434 chars
= SBYTES (string
);
436 if (EQ (printcharfun
, Qt
))
438 /* Output to echo area. */
439 EMACS_INT nbytes
= SBYTES (string
);
442 /* Copy the string contents so that relocation of STRING by
443 GC does not cause trouble. */
446 SAFE_ALLOCA (buffer
, char *, nbytes
);
447 memcpy (buffer
, SDATA (string
), nbytes
);
449 strout (buffer
, chars
, SBYTES (string
),
450 printcharfun
, STRING_MULTIBYTE (string
));
455 /* No need to copy, since output to print_buffer can't GC. */
456 strout (SDATA (string
),
457 chars
, SBYTES (string
),
458 printcharfun
, STRING_MULTIBYTE (string
));
462 /* Otherwise, string may be relocated by printing one char.
463 So re-fetch the string address for each character. */
465 EMACS_INT size
= SCHARS (string
);
466 EMACS_INT size_byte
= SBYTES (string
);
469 if (size
== size_byte
)
470 for (i
= 0; i
< size
; i
++)
471 PRINTCHAR (SREF (string
, i
));
473 for (i
= 0; i
< size_byte
; )
475 /* Here, we must convert each multi-byte form to the
476 corresponding character code before handing it to PRINTCHAR. */
478 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
, len
);
486 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
487 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
488 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
489 (Lisp_Object character
, Lisp_Object printcharfun
)
493 if (NILP (printcharfun
))
494 printcharfun
= Vstandard_output
;
495 CHECK_NUMBER (character
);
497 PRINTCHAR (XINT (character
));
502 /* Used from outside of print.c to print a block of SIZE
503 single-byte chars at DATA on the default output stream.
504 Do not use this on the contents of a Lisp string. */
507 write_string (const char *data
, int size
)
510 Lisp_Object printcharfun
;
512 printcharfun
= Vstandard_output
;
515 strout (data
, size
, size
, printcharfun
, 0);
519 /* Used to print a block of SIZE single-byte chars at DATA on a
520 specified stream PRINTCHARFUN.
521 Do not use this on the contents of a Lisp string. */
524 write_string_1 (const char *data
, int size
, Lisp_Object printcharfun
)
529 strout (data
, size
, size
, printcharfun
, 0);
535 temp_output_buffer_setup (const char *bufname
)
537 int count
= SPECPDL_INDEX ();
538 register struct buffer
*old
= current_buffer
;
539 register Lisp_Object buf
;
541 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
543 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
545 Fkill_all_local_variables ();
546 delete_all_overlays (current_buffer
);
547 current_buffer
->directory
= old
->directory
;
548 current_buffer
->read_only
= Qnil
;
549 current_buffer
->filename
= Qnil
;
550 current_buffer
->undo_list
= Qt
;
551 eassert (current_buffer
->overlays_before
== NULL
);
552 eassert (current_buffer
->overlays_after
== NULL
);
553 current_buffer
->enable_multibyte_characters
554 = buffer_defaults
.enable_multibyte_characters
;
555 specbind (Qinhibit_read_only
, Qt
);
556 specbind (Qinhibit_modification_hooks
, Qt
);
558 XSETBUFFER (buf
, current_buffer
);
560 Frun_hooks (1, &Qtemp_buffer_setup_hook
);
562 unbind_to (count
, Qnil
);
564 specbind (Qstandard_output
, buf
);
568 internal_with_output_to_temp_buffer (const char *bufname
, Lisp_Object (*function
) (Lisp_Object
), Lisp_Object args
)
570 int count
= SPECPDL_INDEX ();
571 Lisp_Object buf
, val
;
575 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
576 temp_output_buffer_setup (bufname
);
577 buf
= Vstandard_output
;
580 val
= (*function
) (args
);
583 temp_output_buffer_show (buf
);
586 return unbind_to (count
, val
);
589 DEFUN ("with-output-to-temp-buffer",
590 Fwith_output_to_temp_buffer
, Swith_output_to_temp_buffer
,
592 doc
: /* Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
594 This construct makes buffer BUFNAME empty before running BODY.
595 It does not make the buffer current for BODY.
596 Instead it binds `standard-output' to that buffer, so that output
597 generated with `prin1' and similar functions in BODY goes into
600 At the end of BODY, this marks buffer BUFNAME unmodifed and displays
601 it in a window, but does not select it. The normal way to do this is
602 by calling `display-buffer', then running `temp-buffer-show-hook'.
603 However, if `temp-buffer-show-function' is non-nil, it calls that
604 function instead (and does not run `temp-buffer-show-hook'). The
605 function gets one argument, the buffer to display.
607 The return value of `with-output-to-temp-buffer' is the value of the
608 last form in BODY. If BODY does not finish normally, the buffer
609 BUFNAME is not displayed.
611 This runs the hook `temp-buffer-setup-hook' before BODY,
612 with the buffer BUFNAME temporarily current. It runs the hook
613 `temp-buffer-show-hook' after displaying buffer BUFNAME, with that
614 buffer temporarily current, and the window that was used to display it
615 temporarily selected. But it doesn't run `temp-buffer-show-hook'
616 if it uses `temp-buffer-show-function'.
618 usage: (with-output-to-temp-buffer BUFNAME BODY...) */)
623 int count
= SPECPDL_INDEX ();
624 Lisp_Object buf
, val
;
627 name
= Feval (Fcar (args
));
629 temp_output_buffer_setup (SDATA (name
));
630 buf
= Vstandard_output
;
633 val
= Fprogn (XCDR (args
));
636 temp_output_buffer_show (buf
);
639 return unbind_to (count
, val
);
643 static void print (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
);
644 static void print_preprocess (Lisp_Object obj
);
645 static void print_preprocess_string (INTERVAL interval
, Lisp_Object arg
);
646 static void print_object (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
);
648 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
649 doc
: /* Output a newline to stream PRINTCHARFUN.
650 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
651 (Lisp_Object printcharfun
)
655 if (NILP (printcharfun
))
656 printcharfun
= Vstandard_output
;
663 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
664 doc
: /* Output the printed representation of OBJECT, any Lisp object.
665 Quoting characters are printed when needed to make output that `read'
666 can handle, whenever this is possible. For complex objects, the behavior
667 is controlled by `print-level' and `print-length', which see.
669 OBJECT is any of the Lisp data types: a number, a string, a symbol,
670 a list, a buffer, a window, a frame, etc.
672 A printed representation of an object is text which describes that object.
674 Optional argument PRINTCHARFUN is the output stream, which can be one
677 - a buffer, in which case output is inserted into that buffer at point;
678 - a marker, in which case output is inserted at marker's position;
679 - a function, in which case that function is called once for each
680 character of OBJECT's printed representation;
681 - a symbol, in which case that symbol's function definition is called; or
682 - t, in which case the output is displayed in the echo area.
684 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
686 (Lisp_Object object
, Lisp_Object printcharfun
)
690 if (NILP (printcharfun
))
691 printcharfun
= Vstandard_output
;
693 print (object
, printcharfun
, 1);
698 /* a buffer which is used to hold output being built by prin1-to-string */
699 Lisp_Object Vprin1_to_string_buffer
;
701 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
702 doc
: /* Return a string containing the printed representation of OBJECT.
703 OBJECT can be any Lisp object. This function outputs quoting characters
704 when necessary to make output that `read' can handle, whenever possible,
705 unless the optional second argument NOESCAPE is non-nil. For complex objects,
706 the behavior is controlled by `print-level' and `print-length', which see.
708 OBJECT is any of the Lisp data types: a number, a string, a symbol,
709 a list, a buffer, a window, a frame, etc.
711 A printed representation of an object is text which describes that object. */)
712 (Lisp_Object object
, Lisp_Object noescape
)
714 Lisp_Object printcharfun
;
715 /* struct gcpro gcpro1, gcpro2; */
716 Lisp_Object save_deactivate_mark
;
717 int count
= SPECPDL_INDEX ();
718 struct buffer
*previous
;
720 specbind (Qinhibit_modification_hooks
, Qt
);
725 /* Save and restore this--we are altering a buffer
726 but we don't want to deactivate the mark just for that.
727 No need for specbind, since errors deactivate the mark. */
728 save_deactivate_mark
= Vdeactivate_mark
;
729 /* GCPRO2 (object, save_deactivate_mark); */
732 printcharfun
= Vprin1_to_string_buffer
;
734 print (object
, printcharfun
, NILP (noescape
));
735 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
739 previous
= current_buffer
;
740 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
741 object
= Fbuffer_string ();
742 if (SBYTES (object
) == SCHARS (object
))
743 STRING_SET_UNIBYTE (object
);
745 /* Note that this won't make prepare_to_modify_buffer call
746 ask-user-about-supersession-threat because this buffer
747 does not visit a file. */
749 set_buffer_internal (previous
);
751 Vdeactivate_mark
= save_deactivate_mark
;
755 return unbind_to (count
, object
);
758 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
759 doc
: /* Output the printed representation of OBJECT, any Lisp object.
760 No quoting characters are used; no delimiters are printed around
761 the contents of strings.
763 OBJECT is any of the Lisp data types: a number, a string, a symbol,
764 a list, a buffer, a window, a frame, etc.
766 A printed representation of an object is text which describes that object.
768 Optional argument PRINTCHARFUN is the output stream, which can be one
771 - a buffer, in which case output is inserted into that buffer at point;
772 - a marker, in which case output is inserted at marker's position;
773 - a function, in which case that function is called once for each
774 character of OBJECT's printed representation;
775 - a symbol, in which case that symbol's function definition is called; or
776 - t, in which case the output is displayed in the echo area.
778 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
780 (Lisp_Object object
, Lisp_Object printcharfun
)
784 if (NILP (printcharfun
))
785 printcharfun
= Vstandard_output
;
787 print (object
, printcharfun
, 0);
792 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
793 doc
: /* Output the printed representation of OBJECT, with newlines around it.
794 Quoting characters are printed when needed to make output that `read'
795 can handle, whenever this is possible. For complex objects, the behavior
796 is controlled by `print-level' and `print-length', which see.
798 OBJECT is any of the Lisp data types: a number, a string, a symbol,
799 a list, a buffer, a window, a frame, etc.
801 A printed representation of an object is text which describes that object.
803 Optional argument PRINTCHARFUN is the output stream, which can be one
806 - a buffer, in which case output is inserted into that buffer at point;
807 - a marker, in which case output is inserted at marker's position;
808 - a function, in which case that function is called once for each
809 character of OBJECT's printed representation;
810 - a symbol, in which case that symbol's function definition is called; or
811 - t, in which case the output is displayed in the echo area.
813 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
815 (Lisp_Object object
, Lisp_Object printcharfun
)
820 if (NILP (printcharfun
))
821 printcharfun
= Vstandard_output
;
825 print (object
, printcharfun
, 1);
832 /* The subroutine object for external-debugging-output is kept here
833 for the convenience of the debugger. */
834 Lisp_Object Qexternal_debugging_output
;
836 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
837 doc
: /* Write CHARACTER to stderr.
838 You can call print while debugging emacs, and pass it this function
839 to make it write to the debugging output. */)
840 (Lisp_Object character
)
842 CHECK_NUMBER (character
);
843 putc ((int) XINT (character
), stderr
);
846 /* Send the output to a debugger (nothing happens if there isn't one). */
847 if (print_output_debug_flag
)
849 char buf
[2] = {(char) XINT (character
), '\0'};
850 OutputDebugString (buf
);
857 /* This function is never called. Its purpose is to prevent
858 print_output_debug_flag from being optimized away. */
861 debug_output_compilation_hack (int x
)
863 print_output_debug_flag
= x
;
866 #if defined (GNU_LINUX)
868 /* This functionality is not vitally important in general, so we rely on
869 non-portable ability to use stderr as lvalue. */
871 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
873 FILE *initial_stderr_stream
= NULL
;
875 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
877 "FDebug output file: \nP",
878 doc
: /* Redirect debugging output (stderr stream) to file FILE.
879 If FILE is nil, reset target to the initial stderr stream.
880 Optional arg APPEND non-nil (interactively, with prefix arg) means
881 append to existing target file. */)
882 (Lisp_Object file
, Lisp_Object append
)
884 if (initial_stderr_stream
!= NULL
)
890 stderr
= initial_stderr_stream
;
891 initial_stderr_stream
= NULL
;
895 file
= Fexpand_file_name (file
, Qnil
);
896 initial_stderr_stream
= stderr
;
897 stderr
= fopen (SDATA (file
), NILP (append
) ? "w" : "a");
900 stderr
= initial_stderr_stream
;
901 initial_stderr_stream
= NULL
;
902 report_file_error ("Cannot open debugging output stream",
908 #endif /* GNU_LINUX */
911 /* This is the interface for debugging printing. */
914 debug_print (Lisp_Object arg
)
916 Fprin1 (arg
, Qexternal_debugging_output
);
917 fprintf (stderr
, "\r\n");
921 safe_debug_print (Lisp_Object arg
)
923 int valid
= valid_lisp_object_p (arg
);
928 fprintf (stderr
, "#<%s_LISP_OBJECT 0x%08lx>\r\n",
929 !valid
? "INVALID" : "SOME",
930 (unsigned long) XHASH (arg
)
935 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
937 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
938 See Info anchor `(elisp)Definition of signal' for some details on how this
939 error message is constructed. */)
942 struct buffer
*old
= current_buffer
;
946 /* If OBJ is (error STRING), just return STRING.
947 That is not only faster, it also avoids the need to allocate
948 space here when the error is due to memory full. */
949 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
950 && CONSP (XCDR (obj
))
951 && STRINGP (XCAR (XCDR (obj
)))
952 && NILP (XCDR (XCDR (obj
))))
953 return XCAR (XCDR (obj
));
955 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
957 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
958 value
= Fbuffer_string ();
962 set_buffer_internal (old
);
968 /* Print an error message for the error DATA onto Lisp output stream
969 STREAM (suitable for the print functions).
970 CONTEXT is a C string describing the context of the error.
971 CALLER is the Lisp function inside which the error was signaled. */
974 print_error_message (Lisp_Object data
, Lisp_Object stream
, const char *context
,
977 Lisp_Object errname
, errmsg
, file_error
, tail
;
982 write_string_1 (context
, -1, stream
);
984 /* If we know from where the error was signaled, show it in
986 if (!NILP (caller
) && SYMBOLP (caller
))
988 Lisp_Object cname
= SYMBOL_NAME (caller
);
989 char *name
= alloca (SBYTES (cname
));
990 memcpy (name
, SDATA (cname
), SBYTES (cname
));
991 message_dolog (name
, SBYTES (cname
), 0, 0);
992 message_dolog (": ", 2, 0, 0);
995 errname
= Fcar (data
);
997 if (EQ (errname
, Qerror
))
1002 errmsg
= Fcar (data
);
1007 Lisp_Object error_conditions
;
1008 errmsg
= Fget (errname
, Qerror_message
);
1009 error_conditions
= Fget (errname
, Qerror_conditions
);
1010 file_error
= Fmemq (Qfile_error
, error_conditions
);
1013 /* Print an error message including the data items. */
1015 tail
= Fcdr_safe (data
);
1018 /* For file-error, make error message by concatenating
1019 all the data items. They are all strings. */
1020 if (!NILP (file_error
) && CONSP (tail
))
1021 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
1023 if (STRINGP (errmsg
))
1024 Fprinc (errmsg
, stream
);
1026 write_string_1 ("peculiar error", -1, stream
);
1028 for (i
= 0; CONSP (tail
); tail
= XCDR (tail
), i
++)
1032 write_string_1 (i
? ", " : ": ", 2, stream
);
1034 if (!NILP (file_error
) || EQ (errname
, Qend_of_file
))
1035 Fprinc (obj
, stream
);
1037 Fprin1 (obj
, stream
);
1046 * The buffer should be at least as large as the max string size of the
1047 * largest float, printed in the biggest notation. This is undoubtedly
1048 * 20d float_output_format, with the negative of the C-constant "HUGE"
1051 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
1053 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
1054 * case of -1e307 in 20d float_output_format. What is one to do (short of
1055 * re-writing _doprnt to be more sane)?
1057 * Given the above, the buffer must be least FLOAT_TO_STRING_BUFSIZE bytes.
1061 float_to_string (unsigned char *buf
, double data
)
1066 /* Check for plus infinity in a way that won't lose
1067 if there is no plus infinity. */
1068 if (data
== data
/ 2 && data
> 1.0)
1070 strcpy (buf
, "1.0e+INF");
1073 /* Likewise for minus infinity. */
1074 if (data
== data
/ 2 && data
< -1.0)
1076 strcpy (buf
, "-1.0e+INF");
1079 /* Check for NaN in a way that won't fail if there are no NaNs. */
1080 if (! (data
* 0.0 >= 0.0))
1082 /* Prepend "-" if the NaN's sign bit is negative.
1083 The sign bit of a double is the bit that is 1 in -0.0. */
1085 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
1087 u_minus_zero
.d
= - 0.0;
1088 for (i
= 0; i
< sizeof (double); i
++)
1089 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
1095 strcpy (buf
, "0.0e+NaN");
1099 if (NILP (Vfloat_output_format
)
1100 || !STRINGP (Vfloat_output_format
))
1103 /* Generate the fewest number of digits that represent the
1104 floating point value without losing information. */
1105 dtoastr (buf
, FLOAT_TO_STRING_BUFSIZE
, 0, 0, data
);
1107 else /* oink oink */
1109 /* Check that the spec we have is fully valid.
1110 This means not only valid for printf,
1111 but meant for floats, and reasonable. */
1112 cp
= SDATA (Vfloat_output_format
);
1121 /* Check the width specification. */
1123 if ('0' <= *cp
&& *cp
<= '9')
1127 width
= (width
* 10) + (*cp
++ - '0');
1128 while (*cp
>= '0' && *cp
<= '9');
1130 /* A precision of zero is valid only for %f. */
1132 || (width
== 0 && *cp
!= 'f'))
1136 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1142 sprintf (buf
, SDATA (Vfloat_output_format
), data
);
1145 /* Make sure there is a decimal point with digit after, or an
1146 exponent, so that the value is readable as a float. But don't do
1147 this with "%.0f"; it's valid for that not to produce a decimal
1148 point. Note that width can be 0 only for %.0f. */
1151 for (cp
= buf
; *cp
; cp
++)
1152 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1155 if (*cp
== '.' && cp
[1] == 0)
1172 print (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
)
1174 new_backquote_output
= 0;
1176 /* Reset print_number_index and Vprint_number_table only when
1177 the variable Vprint_continuous_numbering is nil. Otherwise,
1178 the values of these variables will be kept between several
1180 if (NILP (Vprint_continuous_numbering
)
1181 || NILP (Vprint_number_table
))
1183 print_number_index
= 0;
1184 Vprint_number_table
= Qnil
;
1187 /* Construct Vprint_number_table for print-gensym and print-circle. */
1188 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1190 /* Construct Vprint_number_table.
1191 This increments print_number_index for the objects added. */
1193 print_preprocess (obj
);
1195 if (HASH_TABLE_P (Vprint_number_table
))
1196 { /* Remove unnecessary objects, which appear only once in OBJ;
1197 that is, whose status is Qt.
1198 Maybe a better way to do that is to copy elements to
1199 a new hash table. */
1200 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vprint_number_table
);
1203 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
1204 if (!NILP (HASH_HASH (h
, i
))
1205 && EQ (HASH_VALUE (h
, i
), Qt
))
1206 Fremhash (HASH_KEY (h
, i
), Vprint_number_table
);
1211 print_object (obj
, printcharfun
, escapeflag
);
1214 /* Construct Vprint_number_table according to the structure of OBJ.
1215 OBJ itself and all its elements will be added to Vprint_number_table
1216 recursively if it is a list, vector, compiled function, char-table,
1217 string (its text properties will be traced), or a symbol that has
1218 no obarray (this is for the print-gensym feature).
1219 The status fields of Vprint_number_table mean whether each object appears
1220 more than once in OBJ: Qnil at the first time, and Qt after that . */
1222 print_preprocess (Lisp_Object obj
)
1227 Lisp_Object halftail
;
1229 /* Give up if we go so deep that print_object will get an error. */
1230 /* See similar code in print_object. */
1231 if (print_depth
>= PRINT_CIRCLE
)
1232 error ("Apparently circular structure being printed");
1234 /* Avoid infinite recursion for circular nested structure
1235 in the case where Vprint_circle is nil. */
1236 if (NILP (Vprint_circle
))
1238 for (i
= 0; i
< print_depth
; i
++)
1239 if (EQ (obj
, being_printed
[i
]))
1241 being_printed
[print_depth
] = obj
;
1248 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1249 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
)
1250 || HASH_TABLE_P (obj
)
1251 || (! NILP (Vprint_gensym
)
1253 && !SYMBOL_INTERNED_P (obj
)))
1255 if (!HASH_TABLE_P (Vprint_number_table
))
1257 Lisp_Object args
[2];
1260 Vprint_number_table
= Fmake_hash_table (2, args
);
1263 /* In case print-circle is nil and print-gensym is t,
1264 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1265 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1267 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1269 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1270 always print the gensym with a number. This is a special for
1271 the lisp function byte-compile-output-docform. */
1272 || (!NILP (Vprint_continuous_numbering
)
1274 && !SYMBOL_INTERNED_P (obj
)))
1275 { /* OBJ appears more than once. Let's remember that. */
1276 if (!INTEGERP (num
))
1278 print_number_index
++;
1279 /* Negative number indicates it hasn't been printed yet. */
1280 Fputhash (obj
, make_number (- print_number_index
),
1281 Vprint_number_table
);
1287 /* OBJ is not yet recorded. Let's add to the table. */
1288 Fputhash (obj
, Qt
, Vprint_number_table
);
1291 switch (XTYPE (obj
))
1294 /* A string may have text properties, which can be circular. */
1295 traverse_intervals_noorder (STRING_INTERVALS (obj
),
1296 print_preprocess_string
, Qnil
);
1300 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1301 just as in print_object. */
1302 if (loop_count
&& EQ (obj
, halftail
))
1304 print_preprocess (XCAR (obj
));
1307 if (!(loop_count
& 1))
1308 halftail
= XCDR (halftail
);
1311 case Lisp_Vectorlike
:
1312 size
= XVECTOR (obj
)->size
;
1313 if (size
& PSEUDOVECTOR_FLAG
)
1314 size
&= PSEUDOVECTOR_SIZE_MASK
;
1315 for (i
= 0; i
< size
; i
++)
1316 print_preprocess (XVECTOR (obj
)->contents
[i
]);
1317 if (HASH_TABLE_P (obj
))
1318 { /* For hash tables, the key_and_value slot is past
1319 `size' because it needs to be marked specially in case
1320 the table is weak. */
1321 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1322 print_preprocess (h
->key_and_value
);
1334 print_preprocess_string (INTERVAL interval
, Lisp_Object arg
)
1336 print_preprocess (interval
->plist
);
1339 /* A flag to control printing of `charset' text property.
1340 The default value is Qdefault. */
1341 Lisp_Object Vprint_charset_text_property
;
1343 static void print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
);
1345 #define PRINT_STRING_NON_CHARSET_FOUND 1
1346 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1348 /* Bitwise or of the above macros. */
1349 static int print_check_string_result
;
1352 print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
)
1356 if (NILP (interval
->plist
)
1357 || (print_check_string_result
== (PRINT_STRING_NON_CHARSET_FOUND
1358 | PRINT_STRING_UNSAFE_CHARSET_FOUND
)))
1360 for (val
= interval
->plist
; CONSP (val
) && ! EQ (XCAR (val
), Qcharset
);
1361 val
= XCDR (XCDR (val
)));
1364 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1367 if (! (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
))
1369 if (! EQ (val
, interval
->plist
)
1370 || CONSP (XCDR (XCDR (val
))))
1371 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1373 if (NILP (Vprint_charset_text_property
)
1374 || ! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1377 EMACS_INT charpos
= interval
->position
;
1378 EMACS_INT bytepos
= string_char_to_byte (string
, charpos
);
1379 Lisp_Object charset
;
1381 charset
= XCAR (XCDR (val
));
1382 for (i
= 0; i
< LENGTH (interval
); i
++)
1384 FETCH_STRING_CHAR_ADVANCE (c
, string
, charpos
, bytepos
);
1385 if (! ASCII_CHAR_P (c
)
1386 && ! EQ (CHARSET_NAME (CHAR_CHARSET (c
)), charset
))
1388 print_check_string_result
|= PRINT_STRING_UNSAFE_CHARSET_FOUND
;
1395 /* The value is (charset . nil). */
1396 static Lisp_Object print_prune_charset_plist
;
1399 print_prune_string_charset (Lisp_Object string
)
1401 print_check_string_result
= 0;
1402 traverse_intervals (STRING_INTERVALS (string
), 0,
1403 print_check_string_charset_prop
, string
);
1404 if (! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1406 string
= Fcopy_sequence (string
);
1407 if (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
)
1409 if (NILP (print_prune_charset_plist
))
1410 print_prune_charset_plist
= Fcons (Qcharset
, Qnil
);
1411 Fremove_text_properties (make_number (0),
1412 make_number (SCHARS (string
)),
1413 print_prune_charset_plist
, string
);
1416 Fset_text_properties (make_number (0), make_number (SCHARS (string
)),
1423 print_object (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
)
1429 /* See similar code in print_preprocess. */
1430 if (print_depth
>= PRINT_CIRCLE
)
1431 error ("Apparently circular structure being printed");
1433 /* Detect circularities and truncate them. */
1434 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1435 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
)
1436 || HASH_TABLE_P (obj
)
1437 || (! NILP (Vprint_gensym
)
1439 && !SYMBOL_INTERNED_P (obj
)))
1441 if (NILP (Vprint_circle
) && NILP (Vprint_gensym
))
1443 /* Simple but incomplete way. */
1445 for (i
= 0; i
< print_depth
; i
++)
1446 if (EQ (obj
, being_printed
[i
]))
1448 sprintf (buf
, "#%d", i
);
1449 strout (buf
, -1, -1, printcharfun
, 0);
1452 being_printed
[print_depth
] = obj
;
1456 /* With the print-circle feature. */
1457 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1462 { /* Add a prefix #n= if OBJ has not yet been printed;
1463 that is, its status field is nil. */
1464 sprintf (buf
, "#%d=", -n
);
1465 strout (buf
, -1, -1, printcharfun
, 0);
1466 /* OBJ is going to be printed. Remember that fact. */
1467 Fputhash (obj
, make_number (- n
), Vprint_number_table
);
1471 /* Just print #n# if OBJ has already been printed. */
1472 sprintf (buf
, "#%d#", n
);
1473 strout (buf
, -1, -1, printcharfun
, 0);
1482 switch (XTYPE (obj
))
1485 if (sizeof (int) == sizeof (EMACS_INT
))
1486 sprintf (buf
, "%d", (int) XINT (obj
));
1487 else if (sizeof (long) == sizeof (EMACS_INT
))
1488 sprintf (buf
, "%ld", (long) XINT (obj
));
1491 strout (buf
, -1, -1, printcharfun
, 0);
1496 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
1498 float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1499 strout (pigbuf
, -1, -1, printcharfun
, 0);
1505 print_string (obj
, printcharfun
);
1508 register EMACS_INT i
, i_byte
;
1509 struct gcpro gcpro1
;
1511 EMACS_INT size_byte
;
1512 /* 1 means we must ensure that the next character we output
1513 cannot be taken as part of a hex character escape. */
1514 int need_nonhex
= 0;
1515 int multibyte
= STRING_MULTIBYTE (obj
);
1519 if (! EQ (Vprint_charset_text_property
, Qt
))
1520 obj
= print_prune_string_charset (obj
);
1522 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1530 size_byte
= SBYTES (obj
);
1532 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1534 /* Here, we must convert each multi-byte form to the
1535 corresponding character code before handing it to PRINTCHAR. */
1541 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
, len
);
1549 if (c
== '\n' && print_escape_newlines
)
1554 else if (c
== '\f' && print_escape_newlines
)
1560 && (CHAR_BYTE8_P (c
)
1561 || (! ASCII_CHAR_P (c
) && print_escape_multibyte
)))
1563 /* When multibyte is disabled,
1564 print multibyte string chars using hex escapes.
1565 For a char code that could be in a unibyte string,
1566 when found in a multibyte string, always use a hex escape
1567 so it reads back as multibyte. */
1568 unsigned char outbuf
[50];
1570 if (CHAR_BYTE8_P (c
))
1571 sprintf (outbuf
, "\\%03o", CHAR_TO_BYTE8 (c
));
1574 sprintf (outbuf
, "\\x%04x", c
);
1577 strout (outbuf
, -1, -1, printcharfun
, 0);
1579 else if (! multibyte
1580 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1581 && print_escape_nonascii
)
1583 /* When printing in a multibyte buffer
1584 or when explicitly requested,
1585 print single-byte non-ASCII string chars
1586 using octal escapes. */
1587 unsigned char outbuf
[5];
1588 sprintf (outbuf
, "\\%03o", c
);
1589 strout (outbuf
, -1, -1, printcharfun
, 0);
1593 /* If we just had a hex escape, and this character
1594 could be taken as part of it,
1595 output `\ ' to prevent that. */
1599 if ((c
>= 'a' && c
<= 'f')
1600 || (c
>= 'A' && c
<= 'F')
1601 || (c
>= '0' && c
<= '9'))
1602 strout ("\\ ", -1, -1, printcharfun
, 0);
1605 if (c
== '\"' || c
== '\\')
1612 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1614 traverse_intervals (STRING_INTERVALS (obj
),
1615 0, print_interval
, printcharfun
);
1625 register int confusing
;
1626 register unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1627 register unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1630 EMACS_INT size_byte
;
1633 name
= SYMBOL_NAME (obj
);
1635 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1638 /* If symbol name begins with a digit, and ends with a digit,
1639 and contains nothing but digits and `e', it could be treated
1640 as a number. So set CONFUSING.
1642 Symbols that contain periods could also be taken as numbers,
1643 but periods are always escaped, so we don't have to worry
1645 else if (*p
>= '0' && *p
<= '9'
1646 && end
[-1] >= '0' && end
[-1] <= '9')
1648 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1649 /* Needed for \2e10. */
1650 || *p
== 'e' || *p
== 'E'))
1652 confusing
= (end
== p
);
1657 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1663 size_byte
= SBYTES (name
);
1665 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1667 /* Here, we must convert each multi-byte form to the
1668 corresponding character code before handing it to PRINTCHAR. */
1669 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1674 if (c
== '\"' || c
== '\\' || c
== '\''
1675 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1676 || c
== ',' || c
=='.' || c
== '`'
1677 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1679 PRINTCHAR ('\\'), confusing
= 0;
1687 /* If deeper than spec'd depth, print placeholder. */
1688 if (INTEGERP (Vprint_level
)
1689 && print_depth
> XINT (Vprint_level
))
1690 strout ("...", -1, -1, printcharfun
, 0);
1691 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1692 && (EQ (XCAR (obj
), Qquote
)))
1695 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1697 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1698 && (EQ (XCAR (obj
), Qfunction
)))
1702 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1704 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1705 && ((EQ (XCAR (obj
), Qbackquote
))))
1707 print_object (XCAR (obj
), printcharfun
, 0);
1708 new_backquote_output
++;
1709 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1710 new_backquote_output
--;
1712 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1713 && new_backquote_output
1714 && ((EQ (XCAR (obj
), Qbackquote
)
1715 || EQ (XCAR (obj
), Qcomma
)
1716 || EQ (XCAR (obj
), Qcomma_at
)
1717 || EQ (XCAR (obj
), Qcomma_dot
))))
1719 print_object (XCAR (obj
), printcharfun
, 0);
1720 new_backquote_output
--;
1721 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1722 new_backquote_output
++;
1728 /* If the first element is a backquote form,
1729 print it old-style so it won't be misunderstood. */
1730 if (print_quoted
&& CONSP (XCAR (obj
))
1731 && CONSP (XCDR (XCAR (obj
)))
1732 && NILP (XCDR (XCDR (XCAR (obj
))))
1733 && EQ (XCAR (XCAR (obj
)), Qbackquote
))
1739 print_object (Qbackquote
, printcharfun
, 0);
1742 print_object (XCAR (XCDR (tem
)), printcharfun
, 0);
1749 EMACS_INT print_length
;
1751 Lisp_Object halftail
= obj
;
1753 /* Negative values of print-length are invalid in CL.
1754 Treat them like nil, as CMUCL does. */
1755 if (NATNUMP (Vprint_length
))
1756 print_length
= XFASTINT (Vprint_length
);
1763 /* Detect circular list. */
1764 if (NILP (Vprint_circle
))
1766 /* Simple but imcomplete way. */
1767 if (i
!= 0 && EQ (obj
, halftail
))
1769 sprintf (buf
, " . #%d", i
/ 2);
1770 strout (buf
, -1, -1, printcharfun
, 0);
1776 /* With the print-circle feature. */
1779 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1782 strout (" . ", 3, 3, printcharfun
, 0);
1783 print_object (obj
, printcharfun
, escapeflag
);
1792 if (print_length
&& i
> print_length
)
1794 strout ("...", 3, 3, printcharfun
, 0);
1798 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1802 halftail
= XCDR (halftail
);
1806 /* OBJ non-nil here means it's the end of a dotted list. */
1809 strout (" . ", 3, 3, printcharfun
, 0);
1810 print_object (obj
, printcharfun
, escapeflag
);
1818 case Lisp_Vectorlike
:
1823 strout ("#<process ", -1, -1, printcharfun
, 0);
1824 print_string (XPROCESS (obj
)->name
, printcharfun
);
1828 print_string (XPROCESS (obj
)->name
, printcharfun
);
1830 else if (BOOL_VECTOR_P (obj
))
1833 register unsigned char c
;
1834 struct gcpro gcpro1
;
1835 EMACS_INT size_in_chars
1836 = ((XBOOL_VECTOR (obj
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
1837 / BOOL_VECTOR_BITS_PER_CHAR
);
1843 sprintf (buf
, "%ld", (long) XBOOL_VECTOR (obj
)->size
);
1844 strout (buf
, -1, -1, printcharfun
, 0);
1847 /* Don't print more characters than the specified maximum.
1848 Negative values of print-length are invalid. Treat them
1849 like a print-length of nil. */
1850 if (NATNUMP (Vprint_length
)
1851 && XFASTINT (Vprint_length
) < size_in_chars
)
1852 size_in_chars
= XFASTINT (Vprint_length
);
1854 for (i
= 0; i
< size_in_chars
; i
++)
1857 c
= XBOOL_VECTOR (obj
)->data
[i
];
1858 if (c
== '\n' && print_escape_newlines
)
1863 else if (c
== '\f' && print_escape_newlines
)
1868 else if (c
> '\177')
1870 /* Use octal escapes to avoid encoding issues. */
1872 PRINTCHAR ('0' + ((c
>> 6) & 3));
1873 PRINTCHAR ('0' + ((c
>> 3) & 7));
1874 PRINTCHAR ('0' + (c
& 7));
1878 if (c
== '\"' || c
== '\\')
1887 else if (SUBRP (obj
))
1889 strout ("#<subr ", -1, -1, printcharfun
, 0);
1890 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
, 0);
1893 else if (WINDOWP (obj
))
1895 strout ("#<window ", -1, -1, printcharfun
, 0);
1896 sprintf (buf
, "%ld", (long) XFASTINT (XWINDOW (obj
)->sequence_number
));
1897 strout (buf
, -1, -1, printcharfun
, 0);
1898 if (!NILP (XWINDOW (obj
)->buffer
))
1900 strout (" on ", -1, -1, printcharfun
, 0);
1901 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1905 else if (TERMINALP (obj
))
1907 struct terminal
*t
= XTERMINAL (obj
);
1908 strout ("#<terminal ", -1, -1, printcharfun
, 0);
1909 sprintf (buf
, "%d", t
->id
);
1910 strout (buf
, -1, -1, printcharfun
, 0);
1913 strout (" on ", -1, -1, printcharfun
, 0);
1914 strout (t
->name
, -1, -1, printcharfun
, 0);
1918 else if (HASH_TABLE_P (obj
))
1920 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1922 EMACS_INT real_size
, size
;
1924 strout ("#<hash-table", -1, -1, printcharfun
, 0);
1925 if (SYMBOLP (h
->test
))
1929 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
, 0);
1931 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
, 0);
1933 sprintf (buf
, "%ld/%ld", (long) h
->count
,
1934 (long) XVECTOR (h
->next
)->size
);
1935 strout (buf
, -1, -1, printcharfun
, 0);
1937 sprintf (buf
, " 0x%lx", (unsigned long) h
);
1938 strout (buf
, -1, -1, printcharfun
, 0);
1941 /* Implement a readable output, e.g.:
1942 #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
1943 /* Always print the size. */
1944 sprintf (buf
, "#s(hash-table size %ld",
1945 (long) XVECTOR (h
->next
)->size
);
1946 strout (buf
, -1, -1, printcharfun
, 0);
1948 if (!NILP (h
->test
))
1950 strout (" test ", -1, -1, printcharfun
, 0);
1951 print_object (h
->test
, printcharfun
, 0);
1954 if (!NILP (h
->weak
))
1956 strout (" weakness ", -1, -1, printcharfun
, 0);
1957 print_object (h
->weak
, printcharfun
, 0);
1960 if (!NILP (h
->rehash_size
))
1962 strout (" rehash-size ", -1, -1, printcharfun
, 0);
1963 print_object (h
->rehash_size
, printcharfun
, 0);
1966 if (!NILP (h
->rehash_threshold
))
1968 strout (" rehash-threshold ", -1, -1, printcharfun
, 0);
1969 print_object (h
->rehash_threshold
, printcharfun
, 0);
1972 strout (" data ", -1, -1, printcharfun
, 0);
1974 /* Print the data here as a plist. */
1975 real_size
= HASH_TABLE_SIZE (h
);
1978 /* Don't print more elements than the specified maximum. */
1979 if (NATNUMP (Vprint_length
)
1980 && XFASTINT (Vprint_length
) < size
)
1981 size
= XFASTINT (Vprint_length
);
1984 for (i
= 0; i
< size
; i
++)
1985 if (!NILP (HASH_HASH (h
, i
)))
1987 if (i
) PRINTCHAR (' ');
1988 print_object (HASH_KEY (h
, i
), printcharfun
, 1);
1990 print_object (HASH_VALUE (h
, i
), printcharfun
, 1);
1993 if (size
< real_size
)
1994 strout (" ...", 4, 4, printcharfun
, 0);
2000 else if (BUFFERP (obj
))
2002 if (NILP (XBUFFER (obj
)->name
))
2003 strout ("#<killed buffer>", -1, -1, printcharfun
, 0);
2004 else if (escapeflag
)
2006 strout ("#<buffer ", -1, -1, printcharfun
, 0);
2007 print_string (XBUFFER (obj
)->name
, printcharfun
);
2011 print_string (XBUFFER (obj
)->name
, printcharfun
);
2013 else if (WINDOW_CONFIGURATIONP (obj
))
2015 strout ("#<window-configuration>", -1, -1, printcharfun
, 0);
2017 else if (FRAMEP (obj
))
2019 strout ((FRAME_LIVE_P (XFRAME (obj
))
2020 ? "#<frame " : "#<dead frame "),
2021 -1, -1, printcharfun
, 0);
2022 print_string (XFRAME (obj
)->name
, printcharfun
);
2023 sprintf (buf
, " 0x%lx", (unsigned long) (XFRAME (obj
)));
2024 strout (buf
, -1, -1, printcharfun
, 0);
2027 else if (FONTP (obj
))
2031 if (! FONT_OBJECT_P (obj
))
2033 if (FONT_SPEC_P (obj
))
2034 strout ("#<font-spec", -1, -1, printcharfun
, 0);
2036 strout ("#<font-entity", -1, -1, printcharfun
, 0);
2037 for (i
= 0; i
< FONT_SPEC_MAX
; i
++)
2040 if (i
< FONT_WEIGHT_INDEX
|| i
> FONT_WIDTH_INDEX
)
2041 print_object (AREF (obj
, i
), printcharfun
, escapeflag
);
2043 print_object (font_style_symbolic (obj
, i
, 0),
2044 printcharfun
, escapeflag
);
2049 strout ("#<font-object ", -1, -1, printcharfun
, 0);
2050 print_object (AREF (obj
, FONT_NAME_INDEX
), printcharfun
,
2057 EMACS_INT size
= XVECTOR (obj
)->size
;
2058 if (COMPILEDP (obj
))
2061 size
&= PSEUDOVECTOR_SIZE_MASK
;
2063 if (CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
))
2065 /* We print a char-table as if it were a vector,
2066 lumping the parent and default slots in with the
2067 character slots. But we add #^ as a prefix. */
2069 /* Make each lowest sub_char_table start a new line.
2070 Otherwise we'll make a line extremely long, which
2071 results in slow redisplay. */
2072 if (SUB_CHAR_TABLE_P (obj
)
2073 && XINT (XSUB_CHAR_TABLE (obj
)->depth
) == 3)
2077 if (SUB_CHAR_TABLE_P (obj
))
2079 size
&= PSEUDOVECTOR_SIZE_MASK
;
2081 if (size
& PSEUDOVECTOR_FLAG
)
2087 register Lisp_Object tem
;
2088 EMACS_INT real_size
= size
;
2090 /* Don't print more elements than the specified maximum. */
2091 if (NATNUMP (Vprint_length
)
2092 && XFASTINT (Vprint_length
) < size
)
2093 size
= XFASTINT (Vprint_length
);
2095 for (i
= 0; i
< size
; i
++)
2097 if (i
) PRINTCHAR (' ');
2098 tem
= XVECTOR (obj
)->contents
[i
];
2099 print_object (tem
, printcharfun
, escapeflag
);
2101 if (size
< real_size
)
2102 strout (" ...", 4, 4, printcharfun
, 0);
2109 switch (XMISCTYPE (obj
))
2111 case Lisp_Misc_Marker
:
2112 strout ("#<marker ", -1, -1, printcharfun
, 0);
2113 /* Do you think this is necessary? */
2114 if (XMARKER (obj
)->insertion_type
!= 0)
2115 strout ("(moves after insertion) ", -1, -1, printcharfun
, 0);
2116 if (! XMARKER (obj
)->buffer
)
2117 strout ("in no buffer", -1, -1, printcharfun
, 0);
2120 sprintf (buf
, "at %ld", (long)marker_position (obj
));
2121 strout (buf
, -1, -1, printcharfun
, 0);
2122 strout (" in ", -1, -1, printcharfun
, 0);
2123 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
2128 case Lisp_Misc_Overlay
:
2129 strout ("#<overlay ", -1, -1, printcharfun
, 0);
2130 if (! XMARKER (OVERLAY_START (obj
))->buffer
)
2131 strout ("in no buffer", -1, -1, printcharfun
, 0);
2134 sprintf (buf
, "from %ld to %ld in ",
2135 (long)marker_position (OVERLAY_START (obj
)),
2136 (long)marker_position (OVERLAY_END (obj
)));
2137 strout (buf
, -1, -1, printcharfun
, 0);
2138 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
2144 /* Remaining cases shouldn't happen in normal usage, but let's print
2145 them anyway for the benefit of the debugger. */
2146 case Lisp_Misc_Free
:
2147 strout ("#<misc free cell>", -1, -1, printcharfun
, 0);
2150 case Lisp_Misc_Save_Value
:
2151 strout ("#<save_value ", -1, -1, printcharfun
, 0);
2152 sprintf(buf
, "ptr=0x%08lx int=%d",
2153 (unsigned long) XSAVE_VALUE (obj
)->pointer
,
2154 XSAVE_VALUE (obj
)->integer
);
2155 strout (buf
, -1, -1, printcharfun
, 0);
2167 /* We're in trouble if this happens!
2168 Probably should just abort () */
2169 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
, 0);
2171 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2172 else if (VECTORLIKEP (obj
))
2173 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
2175 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2176 strout (buf
, -1, -1, printcharfun
, 0);
2177 strout (" Save your buffers immediately and please report this bug>",
2178 -1, -1, printcharfun
, 0);
2186 /* Print a description of INTERVAL using PRINTCHARFUN.
2187 This is part of printing a string that has text properties. */
2190 print_interval (INTERVAL interval
, Lisp_Object printcharfun
)
2192 if (NILP (interval
->plist
))
2195 print_object (make_number (interval
->position
), printcharfun
, 1);
2197 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2200 print_object (interval
->plist
, printcharfun
, 1);
2205 syms_of_print (void)
2207 Qtemp_buffer_setup_hook
= intern_c_string ("temp-buffer-setup-hook");
2208 staticpro (&Qtemp_buffer_setup_hook
);
2210 DEFVAR_LISP ("standard-output", &Vstandard_output
,
2211 doc
: /* Output stream `print' uses by default for outputting a character.
2212 This may be any function of one argument.
2213 It may also be a buffer (output is inserted before point)
2214 or a marker (output is inserted and the marker is advanced)
2215 or the symbol t (output appears in the echo area). */);
2216 Vstandard_output
= Qt
;
2217 Qstandard_output
= intern_c_string ("standard-output");
2218 staticpro (&Qstandard_output
);
2220 DEFVAR_LISP ("float-output-format", &Vfloat_output_format
,
2221 doc
: /* The format descriptor string used to print floats.
2222 This is a %-spec like those accepted by `printf' in C,
2223 but with some restrictions. It must start with the two characters `%.'.
2224 After that comes an integer precision specification,
2225 and then a letter which controls the format.
2226 The letters allowed are `e', `f' and `g'.
2227 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2228 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2229 Use `g' to choose the shorter of those two formats for the number at hand.
2230 The precision in any of these cases is the number of digits following
2231 the decimal point. With `f', a precision of 0 means to omit the
2232 decimal point. 0 is not allowed with `e' or `g'.
2234 A value of nil means to use the shortest notation
2235 that represents the number without losing information. */);
2236 Vfloat_output_format
= Qnil
;
2237 Qfloat_output_format
= intern_c_string ("float-output-format");
2238 staticpro (&Qfloat_output_format
);
2240 DEFVAR_LISP ("print-length", &Vprint_length
,
2241 doc
: /* Maximum length of list to print before abbreviating.
2242 A value of nil means no limit. See also `eval-expression-print-length'. */);
2243 Vprint_length
= Qnil
;
2245 DEFVAR_LISP ("print-level", &Vprint_level
,
2246 doc
: /* Maximum depth of list nesting to print before abbreviating.
2247 A value of nil means no limit. See also `eval-expression-print-level'. */);
2248 Vprint_level
= Qnil
;
2250 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines
,
2251 doc
: /* Non-nil means print newlines in strings as `\\n'.
2252 Also print formfeeds as `\\f'. */);
2253 print_escape_newlines
= 0;
2255 DEFVAR_BOOL ("print-escape-nonascii", &print_escape_nonascii
,
2256 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2257 \(OOO is the octal representation of the character code.)
2258 Only single-byte characters are affected, and only in `prin1'.
2259 When the output goes in a multibyte buffer, this feature is
2260 enabled regardless of the value of the variable. */);
2261 print_escape_nonascii
= 0;
2263 DEFVAR_BOOL ("print-escape-multibyte", &print_escape_multibyte
,
2264 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2265 \(XXXX is the hex representation of the character code.)
2266 This affects only `prin1'. */);
2267 print_escape_multibyte
= 0;
2269 DEFVAR_BOOL ("print-quoted", &print_quoted
,
2270 doc
: /* Non-nil means print quoted forms with reader syntax.
2271 I.e., (quote foo) prints as 'foo, (function foo) as #'foo. */);
2274 DEFVAR_LISP ("print-gensym", &Vprint_gensym
,
2275 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2276 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2277 When the uninterned symbol appears within a recursive data structure,
2278 and the symbol appears more than once, in addition use the #N# and #N=
2279 constructs as needed, so that multiple references to the same symbol are
2280 shared once again when the text is read back. */);
2281 Vprint_gensym
= Qnil
;
2283 DEFVAR_LISP ("print-circle", &Vprint_circle
,
2284 doc
: /* *Non-nil means print recursive structures using #N= and #N# syntax.
2285 If nil, printing proceeds recursively and may lead to
2286 `max-lisp-eval-depth' being exceeded or an error may occur:
2287 \"Apparently circular structure being printed.\" Also see
2288 `print-length' and `print-level'.
2289 If non-nil, shared substructures anywhere in the structure are printed
2290 with `#N=' before the first occurrence (in the order of the print
2291 representation) and `#N#' in place of each subsequent occurrence,
2292 where N is a positive decimal integer. */);
2293 Vprint_circle
= Qnil
;
2295 DEFVAR_LISP ("print-continuous-numbering", &Vprint_continuous_numbering
,
2296 doc
: /* *Non-nil means number continuously across print calls.
2297 This affects the numbers printed for #N= labels and #M# references.
2298 See also `print-circle', `print-gensym', and `print-number-table'.
2299 This variable should not be set with `setq'; bind it with a `let' instead. */);
2300 Vprint_continuous_numbering
= Qnil
;
2302 DEFVAR_LISP ("print-number-table", &Vprint_number_table
,
2303 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2304 The Lisp printer uses this vector to detect Lisp objects referenced more
2307 When you bind `print-continuous-numbering' to t, you should probably
2308 also bind `print-number-table' to nil. This ensures that the value of
2309 `print-number-table' can be garbage-collected once the printing is
2310 done. If all elements of `print-number-table' are nil, it means that
2311 the printing done so far has not found any shared structure or objects
2312 that need to be recorded in the table. */);
2313 Vprint_number_table
= Qnil
;
2315 DEFVAR_LISP ("print-charset-text-property", &Vprint_charset_text_property
,
2316 doc
: /* A flag to control printing of `charset' text property on printing a string.
2317 The value must be nil, t, or `default'.
2319 If the value is nil, don't print the text property `charset'.
2321 If the value is t, always print the text property `charset'.
2323 If the value is `default', print the text property `charset' only when
2324 the value is different from what is guessed in the current charset
2326 Vprint_charset_text_property
= Qdefault
;
2328 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2329 staticpro (&Vprin1_to_string_buffer
);
2332 defsubr (&Sprin1_to_string
);
2333 defsubr (&Serror_message_string
);
2337 defsubr (&Swrite_char
);
2338 defsubr (&Sexternal_debugging_output
);
2339 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2340 defsubr (&Sredirect_debugging_output
);
2343 Qexternal_debugging_output
= intern_c_string ("external-debugging-output");
2344 staticpro (&Qexternal_debugging_output
);
2346 Qprint_escape_newlines
= intern_c_string ("print-escape-newlines");
2347 staticpro (&Qprint_escape_newlines
);
2349 Qprint_escape_multibyte
= intern_c_string ("print-escape-multibyte");
2350 staticpro (&Qprint_escape_multibyte
);
2352 Qprint_escape_nonascii
= intern_c_string ("print-escape-nonascii");
2353 staticpro (&Qprint_escape_nonascii
);
2355 print_prune_charset_plist
= Qnil
;
2356 staticpro (&print_prune_charset_plist
);
2358 defsubr (&Swith_output_to_temp_buffer
);
2361 /* arch-tag: bc797170-94ae-41de-86e3-75e20f8f7a39
2362 (do not change this comment) */