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 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, or (at your option)
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; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 Boston, MA 02110-1301, USA. */
33 #include "dispextern.h"
35 #include "intervals.h"
36 #include "blockinput.h"
37 #include "termhooks.h" /* For struct terminal. */
39 Lisp_Object Vstandard_output
, Qstandard_output
;
41 Lisp_Object Qtemp_buffer_setup_hook
;
43 /* These are used to print like we read. */
44 extern Lisp_Object Qbackquote
, Qcomma
, Qcomma_at
, Qcomma_dot
, Qfunction
;
46 Lisp_Object Vfloat_output_format
, Qfloat_output_format
;
48 /* Work around a problem that happens because math.h on hpux 7
49 defines two static variables--which, in Emacs, are not really static,
50 because `static' is defined as nothing. The problem is that they are
51 defined both here and in lread.c.
52 These macros prevent the name conflict. */
53 #if defined (HPUX) && !defined (HPUX8)
54 #define _MAXLDBL print_maxldbl
55 #define _NMAXLDBL print_nmaxldbl
64 /* Default to values appropriate for IEEE floating point. */
69 #define DBL_MANT_DIG 53
75 #define DBL_MIN 2.2250738585072014e-308
78 #ifdef DBL_MIN_REPLACEMENT
80 #define DBL_MIN DBL_MIN_REPLACEMENT
83 /* Define DOUBLE_DIGITS_BOUND, an upper bound on the number of decimal digits
84 needed to express a float without losing information.
85 The general-case formula is valid for the usual case, IEEE floating point,
86 but many compilers can't optimize the formula to an integer constant,
87 so make a special case for it. */
88 #if FLT_RADIX == 2 && DBL_MANT_DIG == 53
89 #define DOUBLE_DIGITS_BOUND 17 /* IEEE floating point */
91 #define DOUBLE_DIGITS_BOUND ((int) ceil (log10 (pow (FLT_RADIX, DBL_MANT_DIG))))
94 /* Avoid actual stack overflow in print. */
97 /* Level of nesting inside outputting backquote in new style. */
98 int new_backquote_output
;
100 /* Detect most circularities to print finite output. */
101 #define PRINT_CIRCLE 200
102 Lisp_Object being_printed
[PRINT_CIRCLE
];
104 /* When printing into a buffer, first we put the text in this
105 block, then insert it all at once. */
108 /* Size allocated in print_buffer. */
109 int print_buffer_size
;
110 /* Chars stored in print_buffer. */
111 int print_buffer_pos
;
112 /* Bytes stored in print_buffer. */
113 int print_buffer_pos_byte
;
115 /* Maximum length of list to print in full; noninteger means
116 effectively infinity */
118 Lisp_Object Vprint_length
;
120 /* Maximum depth of list to print in full; noninteger means
121 effectively infinity. */
123 Lisp_Object Vprint_level
;
125 /* Nonzero means print newlines in strings as \n. */
127 int print_escape_newlines
;
129 /* Nonzero means to print single-byte non-ascii characters in strings as
132 int print_escape_nonascii
;
134 /* Nonzero means to print multibyte characters in strings as hex escapes. */
136 int print_escape_multibyte
;
138 Lisp_Object Qprint_escape_newlines
;
139 Lisp_Object Qprint_escape_multibyte
, Qprint_escape_nonascii
;
141 /* Nonzero means print (quote foo) forms as 'foo, etc. */
145 /* Non-nil means print #: before uninterned symbols. */
147 Lisp_Object Vprint_gensym
;
149 /* Non-nil means print recursive structures using #n= and #n# syntax. */
151 Lisp_Object Vprint_circle
;
153 /* Non-nil means keep continuous number for #n= and #n# syntax
154 between several print functions. */
156 Lisp_Object Vprint_continuous_numbering
;
158 /* Vprint_number_table is a vector like [OBJ1 STAT1 OBJ2 STAT2 ...],
159 where OBJn are objects going to be printed, and STATn are their status,
160 which may be different meanings during process. See the comments of
161 the functions print and print_preprocess for details.
162 print_number_index keeps the last position the next object should be added,
163 twice of which is the actual vector position in Vprint_number_table. */
164 int print_number_index
;
165 Lisp_Object Vprint_number_table
;
167 /* PRINT_NUMBER_OBJECT returns the I'th object in Vprint_number_table TABLE.
168 PRINT_NUMBER_STATUS returns the status of the I'th object in TABLE.
169 See the comment of the variable Vprint_number_table. */
170 #define PRINT_NUMBER_OBJECT(table,i) XVECTOR ((table))->contents[(i) * 2]
171 #define PRINT_NUMBER_STATUS(table,i) XVECTOR ((table))->contents[(i) * 2 + 1]
173 /* Nonzero means print newline to stdout before next minibuffer message.
174 Defined in xdisp.c */
176 extern int noninteractive_need_newline
;
178 extern int minibuffer_auto_raise
;
180 #ifdef MAX_PRINT_CHARS
181 static int print_chars
;
182 static int max_print
;
183 #endif /* MAX_PRINT_CHARS */
185 void print_interval ();
187 /* GDB resets this to zero on W32 to disable OutputDebugString calls. */
188 int print_output_debug_flag
= 1;
191 /* Low level output routines for characters and strings */
193 /* Lisp functions to do output using a stream
194 must have the stream in a variable called printcharfun
195 and must start with PRINTPREPARE, end with PRINTFINISH,
196 and use PRINTDECLARE to declare common variables.
197 Use PRINTCHAR to output one character,
198 or call strout to output a block of characters. */
200 #define PRINTDECLARE \
201 struct buffer *old = current_buffer; \
202 int old_point = -1, start_point = -1; \
203 int old_point_byte = -1, start_point_byte = -1; \
204 int specpdl_count = SPECPDL_INDEX (); \
205 int free_print_buffer = 0; \
206 int multibyte = !NILP (current_buffer->enable_multibyte_characters); \
209 #define PRINTPREPARE \
210 original = printcharfun; \
211 if (NILP (printcharfun)) printcharfun = Qt; \
212 if (BUFFERP (printcharfun)) \
214 if (XBUFFER (printcharfun) != current_buffer) \
215 Fset_buffer (printcharfun); \
216 printcharfun = Qnil; \
218 if (MARKERP (printcharfun)) \
220 EMACS_INT marker_pos; \
221 if (! XMARKER (printcharfun)->buffer) \
222 error ("Marker does not point anywhere"); \
223 if (XMARKER (printcharfun)->buffer != current_buffer) \
224 set_buffer_internal (XMARKER (printcharfun)->buffer); \
225 marker_pos = marker_position (printcharfun); \
226 if (marker_pos < BEGV || marker_pos > ZV) \
227 error ("Marker is outside the accessible part of the buffer"); \
229 old_point_byte = PT_BYTE; \
230 SET_PT_BOTH (marker_pos, \
231 marker_byte_position (printcharfun)); \
233 start_point_byte = PT_BYTE; \
234 printcharfun = Qnil; \
236 if (NILP (printcharfun)) \
238 Lisp_Object string; \
239 if (NILP (current_buffer->enable_multibyte_characters) \
240 && ! print_escape_multibyte) \
241 specbind (Qprint_escape_multibyte, Qt); \
242 if (! NILP (current_buffer->enable_multibyte_characters) \
243 && ! print_escape_nonascii) \
244 specbind (Qprint_escape_nonascii, Qt); \
245 if (print_buffer != 0) \
247 string = make_string_from_bytes (print_buffer, \
249 print_buffer_pos_byte); \
250 record_unwind_protect (print_unwind, string); \
254 print_buffer_size = 1000; \
255 print_buffer = (char *) xmalloc (print_buffer_size); \
256 free_print_buffer = 1; \
258 print_buffer_pos = 0; \
259 print_buffer_pos_byte = 0; \
261 if (EQ (printcharfun, Qt) && ! noninteractive) \
262 setup_echo_area_for_printing (multibyte);
264 #define PRINTFINISH \
265 if (NILP (printcharfun)) \
267 if (print_buffer_pos != print_buffer_pos_byte \
268 && NILP (current_buffer->enable_multibyte_characters)) \
270 unsigned char *temp \
271 = (unsigned char *) alloca (print_buffer_pos + 1); \
272 copy_text (print_buffer, temp, print_buffer_pos_byte, \
274 insert_1_both (temp, print_buffer_pos, \
275 print_buffer_pos, 0, 1, 0); \
278 insert_1_both (print_buffer, print_buffer_pos, \
279 print_buffer_pos_byte, 0, 1, 0); \
280 signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
282 if (free_print_buffer) \
284 xfree (print_buffer); \
287 unbind_to (specpdl_count, Qnil); \
288 if (MARKERP (original)) \
289 set_marker_both (original, Qnil, PT, PT_BYTE); \
290 if (old_point >= 0) \
291 SET_PT_BOTH (old_point + (old_point >= start_point \
292 ? PT - start_point : 0), \
293 old_point_byte + (old_point_byte >= start_point_byte \
294 ? PT_BYTE - start_point_byte : 0)); \
295 if (old != current_buffer) \
296 set_buffer_internal (old);
298 #define PRINTCHAR(ch) printchar (ch, printcharfun)
300 /* This is used to restore the saved contents of print_buffer
301 when there is a recursive call to print. */
304 print_unwind (saved_text
)
305 Lisp_Object saved_text
;
307 bcopy (SDATA (saved_text
), print_buffer
, SCHARS (saved_text
));
312 /* Print character CH using method FUN. FUN nil means print to
313 print_buffer. FUN t means print to echo area or stdout if
314 non-interactive. If FUN is neither nil nor t, call FUN with CH as
322 #ifdef MAX_PRINT_CHARS
325 #endif /* MAX_PRINT_CHARS */
327 if (!NILP (fun
) && !EQ (fun
, Qt
))
328 call1 (fun
, make_number (ch
));
331 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
332 int len
= CHAR_STRING (ch
, str
);
338 if (print_buffer_pos_byte
+ len
>= print_buffer_size
)
339 print_buffer
= (char *) xrealloc (print_buffer
,
340 print_buffer_size
*= 2);
341 bcopy (str
, print_buffer
+ print_buffer_pos_byte
, len
);
342 print_buffer_pos
+= 1;
343 print_buffer_pos_byte
+= len
;
345 else if (noninteractive
)
347 fwrite (str
, 1, len
, stdout
);
348 noninteractive_need_newline
= 1;
353 = !NILP (current_buffer
->enable_multibyte_characters
);
355 setup_echo_area_for_printing (multibyte_p
);
357 message_dolog (str
, len
, 0, multibyte_p
);
363 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
364 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
365 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
366 print_buffer. PRINTCHARFUN t means output to the echo area or to
367 stdout if non-interactive. If neither nil nor t, call Lisp
368 function PRINTCHARFUN for each character printed. MULTIBYTE
369 non-zero means PTR contains multibyte characters.
371 In the case where PRINTCHARFUN is nil, it is safe for PTR to point
372 to data in a Lisp string. Otherwise that is not safe. */
375 strout (ptr
, size
, size_byte
, printcharfun
, multibyte
)
378 Lisp_Object printcharfun
;
382 size_byte
= size
= strlen (ptr
);
384 if (NILP (printcharfun
))
386 if (print_buffer_pos_byte
+ size_byte
> print_buffer_size
)
388 print_buffer_size
= print_buffer_size
* 2 + size_byte
;
389 print_buffer
= (char *) xrealloc (print_buffer
,
392 bcopy (ptr
, print_buffer
+ print_buffer_pos_byte
, size_byte
);
393 print_buffer_pos
+= size
;
394 print_buffer_pos_byte
+= size_byte
;
396 #ifdef MAX_PRINT_CHARS
399 #endif /* MAX_PRINT_CHARS */
401 else if (noninteractive
&& EQ (printcharfun
, Qt
))
403 fwrite (ptr
, 1, size_byte
, stdout
);
404 noninteractive_need_newline
= 1;
406 else if (EQ (printcharfun
, Qt
))
408 /* Output to echo area. We're trying to avoid a little overhead
409 here, that's the reason we don't call printchar to do the
413 = !NILP (current_buffer
->enable_multibyte_characters
);
415 setup_echo_area_for_printing (multibyte_p
);
416 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
418 if (size
== size_byte
)
420 for (i
= 0; i
< size
; ++i
)
421 insert_char ((unsigned char) *ptr
++);
426 for (i
= 0; i
< size_byte
; i
+= len
)
428 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size_byte
- i
, len
);
433 #ifdef MAX_PRINT_CHARS
436 #endif /* MAX_PRINT_CHARS */
440 /* PRINTCHARFUN is a Lisp function. */
443 if (size
== size_byte
)
445 while (i
< size_byte
)
453 while (i
< size_byte
)
455 /* Here, we must convert each multi-byte form to the
456 corresponding character code before handing it to
459 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size_byte
- i
, len
);
467 /* Print the contents of a string STRING using PRINTCHARFUN.
468 It isn't safe to use strout in many cases,
469 because printing one char can relocate. */
472 print_string (string
, printcharfun
)
474 Lisp_Object printcharfun
;
476 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
480 if (STRING_MULTIBYTE (string
))
481 chars
= SCHARS (string
);
482 else if (EQ (printcharfun
, Qt
)
483 ? ! NILP (buffer_defaults
.enable_multibyte_characters
)
484 : ! NILP (current_buffer
->enable_multibyte_characters
))
486 /* If unibyte string STRING contains 8-bit codes, we must
487 convert STRING to a multibyte string containing the same
492 chars
= SBYTES (string
);
493 bytes
= parse_str_to_multibyte (SDATA (string
), chars
);
496 newstr
= make_uninit_multibyte_string (chars
, bytes
);
497 bcopy (SDATA (string
), SDATA (newstr
), chars
);
498 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
503 chars
= SBYTES (string
);
505 if (EQ (printcharfun
, Qt
))
507 /* Output to echo area. */
508 int nbytes
= SBYTES (string
);
511 /* Copy the string contents so that relocation of STRING by
512 GC does not cause trouble. */
515 SAFE_ALLOCA (buffer
, char *, nbytes
);
516 bcopy (SDATA (string
), buffer
, nbytes
);
518 strout (buffer
, chars
, SBYTES (string
),
519 printcharfun
, STRING_MULTIBYTE (string
));
524 /* No need to copy, since output to print_buffer can't GC. */
525 strout (SDATA (string
),
526 chars
, SBYTES (string
),
527 printcharfun
, STRING_MULTIBYTE (string
));
531 /* Otherwise, string may be relocated by printing one char.
532 So re-fetch the string address for each character. */
534 int size
= SCHARS (string
);
535 int size_byte
= SBYTES (string
);
538 if (size
== size_byte
)
539 for (i
= 0; i
< size
; i
++)
540 PRINTCHAR (SREF (string
, i
));
542 for (i
= 0; i
< size_byte
; )
544 /* Here, we must convert each multi-byte form to the
545 corresponding character code before handing it to PRINTCHAR. */
547 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
,
549 if (!CHAR_VALID_P (ch
, 0))
551 ch
= SREF (string
, i
);
561 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
562 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
563 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
564 (character
, printcharfun
)
565 Lisp_Object character
, printcharfun
;
569 if (NILP (printcharfun
))
570 printcharfun
= Vstandard_output
;
571 CHECK_NUMBER (character
);
573 PRINTCHAR (XINT (character
));
578 /* Used from outside of print.c to print a block of SIZE
579 single-byte chars at DATA on the default output stream.
580 Do not use this on the contents of a Lisp string. */
583 write_string (data
, size
)
588 Lisp_Object printcharfun
;
590 printcharfun
= Vstandard_output
;
593 strout (data
, size
, size
, printcharfun
, 0);
597 /* Used from outside of print.c to print a block of SIZE
598 single-byte chars at DATA on a specified stream PRINTCHARFUN.
599 Do not use this on the contents of a Lisp string. */
602 write_string_1 (data
, size
, printcharfun
)
605 Lisp_Object printcharfun
;
610 strout (data
, size
, size
, printcharfun
, 0);
616 temp_output_buffer_setup (bufname
)
619 int count
= SPECPDL_INDEX ();
620 register struct buffer
*old
= current_buffer
;
621 register Lisp_Object buf
;
623 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
625 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
627 Fkill_all_local_variables ();
628 delete_all_overlays (current_buffer
);
629 current_buffer
->directory
= old
->directory
;
630 current_buffer
->read_only
= Qnil
;
631 current_buffer
->filename
= Qnil
;
632 current_buffer
->undo_list
= Qt
;
633 eassert (current_buffer
->overlays_before
== NULL
);
634 eassert (current_buffer
->overlays_after
== NULL
);
635 current_buffer
->enable_multibyte_characters
636 = buffer_defaults
.enable_multibyte_characters
;
637 specbind (Qinhibit_read_only
, Qt
);
638 specbind (Qinhibit_modification_hooks
, Qt
);
640 XSETBUFFER (buf
, current_buffer
);
642 Frun_hooks (1, &Qtemp_buffer_setup_hook
);
644 unbind_to (count
, Qnil
);
646 specbind (Qstandard_output
, buf
);
650 internal_with_output_to_temp_buffer (bufname
, function
, args
)
652 Lisp_Object (*function
) P_ ((Lisp_Object
));
655 int count
= SPECPDL_INDEX ();
656 Lisp_Object buf
, val
;
660 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
661 temp_output_buffer_setup (bufname
);
662 buf
= Vstandard_output
;
665 val
= (*function
) (args
);
668 temp_output_buffer_show (buf
);
671 return unbind_to (count
, val
);
674 DEFUN ("with-output-to-temp-buffer",
675 Fwith_output_to_temp_buffer
, Swith_output_to_temp_buffer
,
677 doc
: /* Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
678 The buffer is cleared out initially, and marked as unmodified when done.
679 All output done by BODY is inserted in that buffer by default.
680 The buffer is displayed in another window, but not selected.
681 The value of the last form in BODY is returned.
682 If BODY does not finish normally, the buffer BUFNAME is not displayed.
684 The hook `temp-buffer-setup-hook' is run before BODY,
685 with the buffer BUFNAME temporarily current.
686 The hook `temp-buffer-show-hook' is run after the buffer is displayed,
687 with the buffer temporarily current, and the window that was used
688 to display it temporarily selected.
690 If variable `temp-buffer-show-function' is non-nil, call it at the end
691 to get the buffer displayed instead of just displaying the non-selected
692 buffer and calling the hook. It gets one argument, the buffer to display.
694 usage: (with-output-to-temp-buffer BUFNAME BODY...) */)
700 int count
= SPECPDL_INDEX ();
701 Lisp_Object buf
, val
;
704 name
= Feval (Fcar (args
));
706 temp_output_buffer_setup (SDATA (name
));
707 buf
= Vstandard_output
;
710 val
= Fprogn (XCDR (args
));
713 temp_output_buffer_show (buf
);
716 return unbind_to (count
, val
);
720 static void print ();
721 static void print_preprocess ();
722 static void print_preprocess_string ();
723 static void print_object ();
725 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
726 doc
: /* Output a newline to stream PRINTCHARFUN.
727 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
729 Lisp_Object printcharfun
;
733 if (NILP (printcharfun
))
734 printcharfun
= Vstandard_output
;
741 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
742 doc
: /* Output the printed representation of OBJECT, any Lisp object.
743 Quoting characters are printed when needed to make output that `read'
744 can handle, whenever this is possible. For complex objects, the behavior
745 is controlled by `print-level' and `print-length', which see.
747 OBJECT is any of the Lisp data types: a number, a string, a symbol,
748 a list, a buffer, a window, a frame, etc.
750 A printed representation of an object is text which describes that object.
752 Optional argument PRINTCHARFUN is the output stream, which can be one
755 - a buffer, in which case output is inserted into that buffer at point;
756 - a marker, in which case output is inserted at marker's position;
757 - a function, in which case that function is called once for each
758 character of OBJECT's printed representation;
759 - a symbol, in which case that symbol's function definition is called; or
760 - t, in which case the output is displayed in the echo area.
762 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
764 (object
, printcharfun
)
765 Lisp_Object object
, printcharfun
;
769 #ifdef MAX_PRINT_CHARS
771 #endif /* MAX_PRINT_CHARS */
772 if (NILP (printcharfun
))
773 printcharfun
= Vstandard_output
;
775 print (object
, printcharfun
, 1);
780 /* a buffer which is used to hold output being built by prin1-to-string */
781 Lisp_Object Vprin1_to_string_buffer
;
783 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
784 doc
: /* Return a string containing the printed representation of OBJECT.
785 OBJECT can be any Lisp object. This function outputs quoting characters
786 when necessary to make output that `read' can handle, whenever possible,
787 unless the optional second argument NOESCAPE is non-nil. For complex objects,
788 the behavior is controlled by `print-level' and `print-length', which see.
790 OBJECT is any of the Lisp data types: a number, a string, a symbol,
791 a list, a buffer, a window, a frame, etc.
793 A printed representation of an object is text which describes that object. */)
795 Lisp_Object object
, noescape
;
797 Lisp_Object printcharfun
;
798 /* struct gcpro gcpro1, gcpro2; */
799 Lisp_Object save_deactivate_mark
;
800 int count
= SPECPDL_INDEX ();
801 struct buffer
*previous
;
803 specbind (Qinhibit_modification_hooks
, Qt
);
808 /* Save and restore this--we are altering a buffer
809 but we don't want to deactivate the mark just for that.
810 No need for specbind, since errors deactivate the mark. */
811 save_deactivate_mark
= Vdeactivate_mark
;
812 /* GCPRO2 (object, save_deactivate_mark); */
815 printcharfun
= Vprin1_to_string_buffer
;
817 print (object
, printcharfun
, NILP (noescape
));
818 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
822 previous
= current_buffer
;
823 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
824 object
= Fbuffer_string ();
825 if (SBYTES (object
) == SCHARS (object
))
826 STRING_SET_UNIBYTE (object
);
828 /* Note that this won't make prepare_to_modify_buffer call
829 ask-user-about-supersession-threat because this buffer
830 does not visit a file. */
832 set_buffer_internal (previous
);
834 Vdeactivate_mark
= save_deactivate_mark
;
838 return unbind_to (count
, object
);
841 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
842 doc
: /* Output the printed representation of OBJECT, any Lisp object.
843 No quoting characters are used; no delimiters are printed around
844 the contents of strings.
846 OBJECT is any of the Lisp data types: a number, a string, a symbol,
847 a list, a buffer, a window, a frame, etc.
849 A printed representation of an object is text which describes that object.
851 Optional argument PRINTCHARFUN is the output stream, which can be one
854 - a buffer, in which case output is inserted into that buffer at point;
855 - a marker, in which case output is inserted at marker's position;
856 - a function, in which case that function is called once for each
857 character of OBJECT's printed representation;
858 - a symbol, in which case that symbol's function definition is called; or
859 - t, in which case the output is displayed in the echo area.
861 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
863 (object
, printcharfun
)
864 Lisp_Object object
, printcharfun
;
868 if (NILP (printcharfun
))
869 printcharfun
= Vstandard_output
;
871 print (object
, printcharfun
, 0);
876 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
877 doc
: /* Output the printed representation of OBJECT, with newlines around it.
878 Quoting characters are printed when needed to make output that `read'
879 can handle, whenever this is possible. For complex objects, the behavior
880 is controlled by `print-level' and `print-length', which see.
882 OBJECT is any of the Lisp data types: a number, a string, a symbol,
883 a list, a buffer, a window, a frame, etc.
885 A printed representation of an object is text which describes that object.
887 Optional argument PRINTCHARFUN is the output stream, which can be one
890 - a buffer, in which case output is inserted into that buffer at point;
891 - a marker, in which case output is inserted at marker's position;
892 - a function, in which case that function is called once for each
893 character of OBJECT's printed representation;
894 - a symbol, in which case that symbol's function definition is called; or
895 - t, in which case the output is displayed in the echo area.
897 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
899 (object
, printcharfun
)
900 Lisp_Object object
, printcharfun
;
905 #ifdef MAX_PRINT_CHARS
907 max_print
= MAX_PRINT_CHARS
;
908 #endif /* MAX_PRINT_CHARS */
909 if (NILP (printcharfun
))
910 printcharfun
= Vstandard_output
;
914 print (object
, printcharfun
, 1);
917 #ifdef MAX_PRINT_CHARS
920 #endif /* MAX_PRINT_CHARS */
925 /* The subroutine object for external-debugging-output is kept here
926 for the convenience of the debugger. */
927 Lisp_Object Qexternal_debugging_output
;
929 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
930 doc
: /* Write CHARACTER to stderr.
931 You can call print while debugging emacs, and pass it this function
932 to make it write to the debugging output. */)
934 Lisp_Object character
;
936 CHECK_NUMBER (character
);
937 putc (XINT (character
), stderr
);
940 /* Send the output to a debugger (nothing happens if there isn't one). */
941 if (print_output_debug_flag
)
943 char buf
[2] = {(char) XINT (character
), '\0'};
944 OutputDebugString (buf
);
951 /* This function is never called. Its purpose is to prevent
952 print_output_debug_flag from being optimized away. */
955 debug_output_compilation_hack (x
)
958 print_output_debug_flag
= x
;
961 #if defined (GNU_LINUX)
963 /* This functionality is not vitally important in general, so we rely on
964 non-portable ability to use stderr as lvalue. */
966 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
968 FILE *initial_stderr_stream
= NULL
;
970 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
972 "FDebug output file: \nP",
973 doc
: /* Redirect debugging output (stderr stream) to file FILE.
974 If FILE is nil, reset target to the initial stderr stream.
975 Optional arg APPEND non-nil (interactively, with prefix arg) means
976 append to existing target file. */)
978 Lisp_Object file
, append
;
980 if (initial_stderr_stream
!= NULL
)
986 stderr
= initial_stderr_stream
;
987 initial_stderr_stream
= NULL
;
991 file
= Fexpand_file_name (file
, Qnil
);
992 initial_stderr_stream
= stderr
;
993 stderr
= fopen (SDATA (file
), NILP (append
) ? "w" : "a");
996 stderr
= initial_stderr_stream
;
997 initial_stderr_stream
= NULL
;
998 report_file_error ("Cannot open debugging output stream",
1004 #endif /* GNU_LINUX */
1007 /* This is the interface for debugging printing. */
1013 Fprin1 (arg
, Qexternal_debugging_output
);
1014 fprintf (stderr
, "\r\n");
1018 safe_debug_print (arg
)
1021 int valid
= valid_lisp_object_p (arg
);
1026 fprintf (stderr
, "#<%s_LISP_OBJECT 0x%08lx>\r\n",
1027 !valid
? "INVALID" : "SOME",
1028 #ifdef NO_UNION_TYPE
1031 (unsigned long) arg
.i
1037 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
1039 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
1040 See Info anchor `(elisp)Definition of signal' for some details on how this
1041 error message is constructed. */)
1045 struct buffer
*old
= current_buffer
;
1047 struct gcpro gcpro1
;
1049 /* If OBJ is (error STRING), just return STRING.
1050 That is not only faster, it also avoids the need to allocate
1051 space here when the error is due to memory full. */
1052 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
1053 && CONSP (XCDR (obj
))
1054 && STRINGP (XCAR (XCDR (obj
)))
1055 && NILP (XCDR (XCDR (obj
))))
1056 return XCAR (XCDR (obj
));
1058 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
1060 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
1061 value
= Fbuffer_string ();
1065 set_buffer_internal (old
);
1071 /* Print an error message for the error DATA onto Lisp output stream
1072 STREAM (suitable for the print functions).
1073 CONTEXT is a C string describing the context of the error.
1074 CALLER is the Lisp function inside which the error was signaled. */
1077 print_error_message (data
, stream
, context
, caller
)
1078 Lisp_Object data
, stream
;
1082 Lisp_Object errname
, errmsg
, file_error
, tail
;
1083 struct gcpro gcpro1
;
1087 write_string_1 (context
, -1, stream
);
1089 /* If we know from where the error was signaled, show it in
1091 if (!NILP (caller
) && SYMBOLP (caller
))
1093 Lisp_Object cname
= SYMBOL_NAME (caller
);
1094 char *name
= alloca (SBYTES (cname
));
1095 bcopy (SDATA (cname
), name
, SBYTES (cname
));
1096 message_dolog (name
, SBYTES (cname
), 0, 0);
1097 message_dolog (": ", 2, 0, 0);
1100 errname
= Fcar (data
);
1102 if (EQ (errname
, Qerror
))
1107 errmsg
= Fcar (data
);
1112 Lisp_Object error_conditions
;
1113 errmsg
= Fget (errname
, Qerror_message
);
1114 error_conditions
= Fget (errname
, Qerror_conditions
);
1115 file_error
= Fmemq (Qfile_error
, error_conditions
);
1118 /* Print an error message including the data items. */
1120 tail
= Fcdr_safe (data
);
1123 /* For file-error, make error message by concatenating
1124 all the data items. They are all strings. */
1125 if (!NILP (file_error
) && CONSP (tail
))
1126 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
1128 if (STRINGP (errmsg
))
1129 Fprinc (errmsg
, stream
);
1131 write_string_1 ("peculiar error", -1, stream
);
1133 for (i
= 0; CONSP (tail
); tail
= XCDR (tail
), i
++)
1137 write_string_1 (i
? ", " : ": ", 2, stream
);
1139 if (!NILP (file_error
) || EQ (errname
, Qend_of_file
))
1140 Fprinc (obj
, stream
);
1142 Fprin1 (obj
, stream
);
1151 * The buffer should be at least as large as the max string size of the
1152 * largest float, printed in the biggest notation. This is undoubtedly
1153 * 20d float_output_format, with the negative of the C-constant "HUGE"
1156 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
1158 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
1159 * case of -1e307 in 20d float_output_format. What is one to do (short of
1160 * re-writing _doprnt to be more sane)?
1165 float_to_string (buf
, data
)
1172 /* Check for plus infinity in a way that won't lose
1173 if there is no plus infinity. */
1174 if (data
== data
/ 2 && data
> 1.0)
1176 strcpy (buf
, "1.0e+INF");
1179 /* Likewise for minus infinity. */
1180 if (data
== data
/ 2 && data
< -1.0)
1182 strcpy (buf
, "-1.0e+INF");
1185 /* Check for NaN in a way that won't fail if there are no NaNs. */
1186 if (! (data
* 0.0 >= 0.0))
1188 /* Prepend "-" if the NaN's sign bit is negative.
1189 The sign bit of a double is the bit that is 1 in -0.0. */
1191 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
1193 u_minus_zero
.d
= - 0.0;
1194 for (i
= 0; i
< sizeof (double); i
++)
1195 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
1201 strcpy (buf
, "0.0e+NaN");
1205 if (NILP (Vfloat_output_format
)
1206 || !STRINGP (Vfloat_output_format
))
1209 /* Generate the fewest number of digits that represent the
1210 floating point value without losing information.
1211 The following method is simple but a bit slow.
1212 For ideas about speeding things up, please see:
1214 Guy L Steele Jr & Jon L White, How to print floating-point numbers
1215 accurately. SIGPLAN notices 25, 6 (June 1990), 112-126.
1217 Robert G Burger & R Kent Dybvig, Printing floating point numbers
1218 quickly and accurately, SIGPLAN notices 31, 5 (May 1996), 108-116. */
1220 width
= fabs (data
) < DBL_MIN
? 1 : DBL_DIG
;
1222 sprintf (buf
, "%.*g", width
, data
);
1223 while (width
++ < DOUBLE_DIGITS_BOUND
&& atof (buf
) != data
);
1225 else /* oink oink */
1227 /* Check that the spec we have is fully valid.
1228 This means not only valid for printf,
1229 but meant for floats, and reasonable. */
1230 cp
= SDATA (Vfloat_output_format
);
1239 /* Check the width specification. */
1241 if ('0' <= *cp
&& *cp
<= '9')
1245 width
= (width
* 10) + (*cp
++ - '0');
1246 while (*cp
>= '0' && *cp
<= '9');
1248 /* A precision of zero is valid only for %f. */
1250 || (width
== 0 && *cp
!= 'f'))
1254 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1260 sprintf (buf
, SDATA (Vfloat_output_format
), data
);
1263 /* Make sure there is a decimal point with digit after, or an
1264 exponent, so that the value is readable as a float. But don't do
1265 this with "%.0f"; it's valid for that not to produce a decimal
1266 point. Note that width can be 0 only for %.0f. */
1269 for (cp
= buf
; *cp
; cp
++)
1270 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1273 if (*cp
== '.' && cp
[1] == 0)
1290 print (obj
, printcharfun
, escapeflag
)
1292 register Lisp_Object printcharfun
;
1295 new_backquote_output
= 0;
1297 /* Reset print_number_index and Vprint_number_table only when
1298 the variable Vprint_continuous_numbering is nil. Otherwise,
1299 the values of these variables will be kept between several
1301 if (NILP (Vprint_continuous_numbering
)
1302 || NILP (Vprint_number_table
))
1304 print_number_index
= 0;
1305 Vprint_number_table
= Qnil
;
1308 /* Construct Vprint_number_table for print-gensym and print-circle. */
1309 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1311 int i
, start
, index
;
1312 start
= index
= print_number_index
;
1313 /* Construct Vprint_number_table.
1314 This increments print_number_index for the objects added. */
1316 print_preprocess (obj
);
1318 /* Remove unnecessary objects, which appear only once in OBJ;
1319 that is, whose status is Qnil. Compactify the necessary objects. */
1320 for (i
= start
; i
< print_number_index
; i
++)
1321 if (!NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1323 PRINT_NUMBER_OBJECT (Vprint_number_table
, index
)
1324 = PRINT_NUMBER_OBJECT (Vprint_number_table
, i
);
1328 /* Clear out objects outside the active part of the table. */
1329 for (i
= index
; i
< print_number_index
; i
++)
1330 PRINT_NUMBER_OBJECT (Vprint_number_table
, i
) = Qnil
;
1332 /* Reset the status field for the next print step. Now this
1333 field means whether the object has already been printed. */
1334 for (i
= start
; i
< print_number_index
; i
++)
1335 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qnil
;
1337 print_number_index
= index
;
1341 print_object (obj
, printcharfun
, escapeflag
);
1344 /* Construct Vprint_number_table according to the structure of OBJ.
1345 OBJ itself and all its elements will be added to Vprint_number_table
1346 recursively if it is a list, vector, compiled function, char-table,
1347 string (its text properties will be traced), or a symbol that has
1348 no obarray (this is for the print-gensym feature).
1349 The status fields of Vprint_number_table mean whether each object appears
1350 more than once in OBJ: Qnil at the first time, and Qt after that . */
1352 print_preprocess (obj
)
1358 Lisp_Object halftail
;
1360 /* Give up if we go so deep that print_object will get an error. */
1361 /* See similar code in print_object. */
1362 if (print_depth
>= PRINT_CIRCLE
)
1363 error ("Apparently circular structure being printed");
1365 /* Avoid infinite recursion for circular nested structure
1366 in the case where Vprint_circle is nil. */
1367 if (NILP (Vprint_circle
))
1369 for (i
= 0; i
< print_depth
; i
++)
1370 if (EQ (obj
, being_printed
[i
]))
1372 being_printed
[print_depth
] = obj
;
1379 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1380 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
)
1381 || (! NILP (Vprint_gensym
)
1383 && !SYMBOL_INTERNED_P (obj
)))
1385 /* In case print-circle is nil and print-gensym is t,
1386 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1387 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1389 for (i
= 0; i
< print_number_index
; i
++)
1390 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
), obj
))
1392 /* OBJ appears more than once. Let's remember that. */
1393 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1398 /* OBJ is not yet recorded. Let's add to the table. */
1399 if (print_number_index
== 0)
1401 /* Initialize the table. */
1402 Vprint_number_table
= Fmake_vector (make_number (40), Qnil
);
1404 else if (XVECTOR (Vprint_number_table
)->size
== print_number_index
* 2)
1406 /* Reallocate the table. */
1407 int i
= print_number_index
* 4;
1408 Lisp_Object old_table
= Vprint_number_table
;
1409 Vprint_number_table
= Fmake_vector (make_number (i
), Qnil
);
1410 for (i
= 0; i
< print_number_index
; i
++)
1412 PRINT_NUMBER_OBJECT (Vprint_number_table
, i
)
1413 = PRINT_NUMBER_OBJECT (old_table
, i
);
1414 PRINT_NUMBER_STATUS (Vprint_number_table
, i
)
1415 = PRINT_NUMBER_STATUS (old_table
, i
);
1418 PRINT_NUMBER_OBJECT (Vprint_number_table
, print_number_index
) = obj
;
1419 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1420 always print the gensym with a number. This is a special for
1421 the lisp function byte-compile-output-docform. */
1422 if (!NILP (Vprint_continuous_numbering
)
1424 && !SYMBOL_INTERNED_P (obj
))
1425 PRINT_NUMBER_STATUS (Vprint_number_table
, print_number_index
) = Qt
;
1426 print_number_index
++;
1429 switch (XGCTYPE (obj
))
1432 /* A string may have text properties, which can be circular. */
1433 traverse_intervals_noorder (STRING_INTERVALS (obj
),
1434 print_preprocess_string
, Qnil
);
1438 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1439 just as in print_object. */
1440 if (loop_count
&& EQ (obj
, halftail
))
1442 print_preprocess (XCAR (obj
));
1445 if (!(loop_count
& 1))
1446 halftail
= XCDR (halftail
);
1449 case Lisp_Vectorlike
:
1450 size
= XVECTOR (obj
)->size
;
1451 if (size
& PSEUDOVECTOR_FLAG
)
1452 size
&= PSEUDOVECTOR_SIZE_MASK
;
1453 for (i
= 0; i
< size
; i
++)
1454 print_preprocess (XVECTOR (obj
)->contents
[i
]);
1465 print_preprocess_string (interval
, arg
)
1469 print_preprocess (interval
->plist
);
1473 print_object (obj
, printcharfun
, escapeflag
)
1475 register Lisp_Object printcharfun
;
1482 /* Detect circularities and truncate them. */
1483 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1484 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
)
1485 || (! NILP (Vprint_gensym
)
1487 && !SYMBOL_INTERNED_P (obj
)))
1489 if (NILP (Vprint_circle
) && NILP (Vprint_gensym
))
1491 /* Simple but incomplete way. */
1493 for (i
= 0; i
< print_depth
; i
++)
1494 if (EQ (obj
, being_printed
[i
]))
1496 sprintf (buf
, "#%d", i
);
1497 strout (buf
, -1, -1, printcharfun
, 0);
1500 being_printed
[print_depth
] = obj
;
1504 /* With the print-circle feature. */
1506 for (i
= 0; i
< print_number_index
; i
++)
1507 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
), obj
))
1509 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1511 /* Add a prefix #n= if OBJ has not yet been printed;
1512 that is, its status field is nil. */
1513 sprintf (buf
, "#%d=", i
+ 1);
1514 strout (buf
, -1, -1, printcharfun
, 0);
1515 /* OBJ is going to be printed. Set the status to t. */
1516 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1521 /* Just print #n# if OBJ has already been printed. */
1522 sprintf (buf
, "#%d#", i
+ 1);
1523 strout (buf
, -1, -1, printcharfun
, 0);
1532 /* See similar code in print_preprocess. */
1533 if (print_depth
> PRINT_CIRCLE
)
1534 error ("Apparently circular structure being printed");
1535 #ifdef MAX_PRINT_CHARS
1536 if (max_print
&& print_chars
> max_print
)
1541 #endif /* MAX_PRINT_CHARS */
1543 switch (XGCTYPE (obj
))
1546 if (sizeof (int) == sizeof (EMACS_INT
))
1547 sprintf (buf
, "%d", XINT (obj
));
1548 else if (sizeof (long) == sizeof (EMACS_INT
))
1549 sprintf (buf
, "%ld", (long) XINT (obj
));
1552 strout (buf
, -1, -1, printcharfun
, 0);
1557 char pigbuf
[350]; /* see comments in float_to_string */
1559 float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1560 strout (pigbuf
, -1, -1, printcharfun
, 0);
1566 print_string (obj
, printcharfun
);
1569 register int i
, i_byte
;
1570 struct gcpro gcpro1
;
1573 /* 1 means we must ensure that the next character we output
1574 cannot be taken as part of a hex character escape. */
1575 int need_nonhex
= 0;
1576 int multibyte
= STRING_MULTIBYTE (obj
);
1580 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1588 size_byte
= SBYTES (obj
);
1590 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1592 /* Here, we must convert each multi-byte form to the
1593 corresponding character code before handing it to PRINTCHAR. */
1599 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
,
1600 size_byte
- i_byte
, len
);
1601 if (CHAR_VALID_P (c
, 0))
1611 if (c
== '\n' && print_escape_newlines
)
1616 else if (c
== '\f' && print_escape_newlines
)
1622 && ! ASCII_BYTE_P (c
)
1623 && (SINGLE_BYTE_CHAR_P (c
) || print_escape_multibyte
))
1625 /* When multibyte is disabled,
1626 print multibyte string chars using hex escapes.
1627 For a char code that could be in a unibyte string,
1628 when found in a multibyte string, always use a hex escape
1629 so it reads back as multibyte. */
1630 unsigned char outbuf
[50];
1631 sprintf (outbuf
, "\\x%x", c
);
1632 strout (outbuf
, -1, -1, printcharfun
, 0);
1635 else if (! multibyte
1636 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1637 && print_escape_nonascii
)
1639 /* When printing in a multibyte buffer
1640 or when explicitly requested,
1641 print single-byte non-ASCII string chars
1642 using octal escapes. */
1643 unsigned char outbuf
[5];
1644 sprintf (outbuf
, "\\%03o", c
);
1645 strout (outbuf
, -1, -1, printcharfun
, 0);
1649 /* If we just had a hex escape, and this character
1650 could be taken as part of it,
1651 output `\ ' to prevent that. */
1655 if ((c
>= 'a' && c
<= 'f')
1656 || (c
>= 'A' && c
<= 'F')
1657 || (c
>= '0' && c
<= '9'))
1658 strout ("\\ ", -1, -1, printcharfun
, 0);
1661 if (c
== '\"' || c
== '\\')
1668 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1670 traverse_intervals (STRING_INTERVALS (obj
),
1671 0, print_interval
, printcharfun
);
1681 register int confusing
;
1682 register unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1683 register unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1685 int i
, i_byte
, size_byte
;
1688 name
= SYMBOL_NAME (obj
);
1690 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1693 /* If symbol name begins with a digit, and ends with a digit,
1694 and contains nothing but digits and `e', it could be treated
1695 as a number. So set CONFUSING.
1697 Symbols that contain periods could also be taken as numbers,
1698 but periods are always escaped, so we don't have to worry
1700 else if (*p
>= '0' && *p
<= '9'
1701 && end
[-1] >= '0' && end
[-1] <= '9')
1703 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1704 /* Needed for \2e10. */
1707 confusing
= (end
== p
);
1712 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1718 size_byte
= SBYTES (name
);
1720 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1722 /* Here, we must convert each multi-byte form to the
1723 corresponding character code before handing it to PRINTCHAR. */
1724 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1729 if (c
== '\"' || c
== '\\' || c
== '\''
1730 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1731 || c
== ',' || c
=='.' || c
== '`'
1732 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1734 PRINTCHAR ('\\'), confusing
= 0;
1742 /* If deeper than spec'd depth, print placeholder. */
1743 if (INTEGERP (Vprint_level
)
1744 && print_depth
> XINT (Vprint_level
))
1745 strout ("...", -1, -1, printcharfun
, 0);
1746 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1747 && (EQ (XCAR (obj
), Qquote
)))
1750 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1752 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1753 && (EQ (XCAR (obj
), Qfunction
)))
1757 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1759 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1760 && ((EQ (XCAR (obj
), Qbackquote
))))
1762 print_object (XCAR (obj
), printcharfun
, 0);
1763 new_backquote_output
++;
1764 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1765 new_backquote_output
--;
1767 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1768 && new_backquote_output
1769 && ((EQ (XCAR (obj
), Qbackquote
)
1770 || EQ (XCAR (obj
), Qcomma
)
1771 || EQ (XCAR (obj
), Qcomma_at
)
1772 || EQ (XCAR (obj
), Qcomma_dot
))))
1774 print_object (XCAR (obj
), printcharfun
, 0);
1775 new_backquote_output
--;
1776 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1777 new_backquote_output
++;
1783 /* If the first element is a backquote form,
1784 print it old-style so it won't be misunderstood. */
1785 if (print_quoted
&& CONSP (XCAR (obj
))
1786 && CONSP (XCDR (XCAR (obj
)))
1787 && NILP (XCDR (XCDR (XCAR (obj
))))
1788 && EQ (XCAR (XCAR (obj
)), Qbackquote
))
1794 print_object (Qbackquote
, printcharfun
, 0);
1797 print_object (XCAR (XCDR (tem
)), printcharfun
, 0);
1804 int print_length
, i
;
1805 Lisp_Object halftail
= obj
;
1807 /* Negative values of print-length are invalid in CL.
1808 Treat them like nil, as CMUCL does. */
1809 if (NATNUMP (Vprint_length
))
1810 print_length
= XFASTINT (Vprint_length
);
1817 /* Detect circular list. */
1818 if (NILP (Vprint_circle
))
1820 /* Simple but imcomplete way. */
1821 if (i
!= 0 && EQ (obj
, halftail
))
1823 sprintf (buf
, " . #%d", i
/ 2);
1824 strout (buf
, -1, -1, printcharfun
, 0);
1830 /* With the print-circle feature. */
1834 for (i
= 0; i
< print_number_index
; i
++)
1835 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
),
1838 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1840 strout (" . ", 3, 3, printcharfun
, 0);
1841 print_object (obj
, printcharfun
, escapeflag
);
1845 sprintf (buf
, " . #%d#", i
+ 1);
1846 strout (buf
, -1, -1, printcharfun
, 0);
1856 if (print_length
&& i
> print_length
)
1858 strout ("...", 3, 3, printcharfun
, 0);
1862 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1866 halftail
= XCDR (halftail
);
1870 /* OBJ non-nil here means it's the end of a dotted list. */
1873 strout (" . ", 3, 3, printcharfun
, 0);
1874 print_object (obj
, printcharfun
, escapeflag
);
1882 case Lisp_Vectorlike
:
1887 strout ("#<process ", -1, -1, printcharfun
, 0);
1888 print_string (XPROCESS (obj
)->name
, printcharfun
);
1892 print_string (XPROCESS (obj
)->name
, printcharfun
);
1894 else if (BOOL_VECTOR_P (obj
))
1897 register unsigned char c
;
1898 struct gcpro gcpro1
;
1900 = ((XBOOL_VECTOR (obj
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
1901 / BOOL_VECTOR_BITS_PER_CHAR
);
1907 sprintf (buf
, "%ld", (long) XBOOL_VECTOR (obj
)->size
);
1908 strout (buf
, -1, -1, printcharfun
, 0);
1911 /* Don't print more characters than the specified maximum.
1912 Negative values of print-length are invalid. Treat them
1913 like a print-length of nil. */
1914 if (NATNUMP (Vprint_length
)
1915 && XFASTINT (Vprint_length
) < size_in_chars
)
1916 size_in_chars
= XFASTINT (Vprint_length
);
1918 for (i
= 0; i
< size_in_chars
; i
++)
1921 c
= XBOOL_VECTOR (obj
)->data
[i
];
1922 if (c
== '\n' && print_escape_newlines
)
1927 else if (c
== '\f' && print_escape_newlines
)
1932 else if (c
> '\177')
1934 /* Use octal escapes to avoid encoding issues. */
1936 PRINTCHAR ('0' + ((c
>> 6) & 3));
1937 PRINTCHAR ('0' + ((c
>> 3) & 7));
1938 PRINTCHAR ('0' + (c
& 7));
1942 if (c
== '\"' || c
== '\\')
1951 else if (SUBRP (obj
))
1953 strout ("#<subr ", -1, -1, printcharfun
, 0);
1954 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
, 0);
1957 else if (WINDOWP (obj
))
1959 strout ("#<window ", -1, -1, printcharfun
, 0);
1960 sprintf (buf
, "%ld", (long) XFASTINT (XWINDOW (obj
)->sequence_number
));
1961 strout (buf
, -1, -1, printcharfun
, 0);
1962 if (!NILP (XWINDOW (obj
)->buffer
))
1964 strout (" on ", -1, -1, printcharfun
, 0);
1965 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1969 else if (TERMINALP (obj
))
1971 struct terminal
*t
= XTERMINAL (obj
);
1972 strout ("#<terminal ", -1, -1, printcharfun
, 0);
1973 sprintf (buf
, "%d", t
->id
);
1974 strout (buf
, -1, -1, printcharfun
, 0);
1977 strout (" on ", -1, -1, printcharfun
, 0);
1978 strout (t
->name
, -1, -1, printcharfun
, 0);
1982 else if (HASH_TABLE_P (obj
))
1984 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1985 strout ("#<hash-table", -1, -1, printcharfun
, 0);
1986 if (SYMBOLP (h
->test
))
1990 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
, 0);
1992 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
, 0);
1994 sprintf (buf
, "%ld/%ld", (long) XFASTINT (h
->count
),
1995 (long) XVECTOR (h
->next
)->size
);
1996 strout (buf
, -1, -1, printcharfun
, 0);
1998 sprintf (buf
, " 0x%lx", (unsigned long) h
);
1999 strout (buf
, -1, -1, printcharfun
, 0);
2002 else if (BUFFERP (obj
))
2004 if (NILP (XBUFFER (obj
)->name
))
2005 strout ("#<killed buffer>", -1, -1, printcharfun
, 0);
2006 else if (escapeflag
)
2008 strout ("#<buffer ", -1, -1, printcharfun
, 0);
2009 print_string (XBUFFER (obj
)->name
, printcharfun
);
2013 print_string (XBUFFER (obj
)->name
, printcharfun
);
2015 else if (WINDOW_CONFIGURATIONP (obj
))
2017 strout ("#<window-configuration>", -1, -1, printcharfun
, 0);
2019 else if (FRAMEP (obj
))
2021 strout ((FRAME_LIVE_P (XFRAME (obj
))
2022 ? "#<frame " : "#<dead frame "),
2023 -1, -1, printcharfun
, 0);
2024 print_string (XFRAME (obj
)->name
, printcharfun
);
2025 sprintf (buf
, " 0x%lx", (unsigned long) (XFRAME (obj
)));
2026 strout (buf
, -1, -1, printcharfun
, 0);
2031 EMACS_INT size
= XVECTOR (obj
)->size
;
2032 if (COMPILEDP (obj
))
2035 size
&= PSEUDOVECTOR_SIZE_MASK
;
2037 if (CHAR_TABLE_P (obj
))
2039 /* We print a char-table as if it were a vector,
2040 lumping the parent and default slots in with the
2041 character slots. But we add #^ as a prefix. */
2044 if (SUB_CHAR_TABLE_P (obj
))
2046 size
&= PSEUDOVECTOR_SIZE_MASK
;
2048 if (size
& PSEUDOVECTOR_FLAG
)
2054 register Lisp_Object tem
;
2055 int real_size
= size
;
2057 /* Don't print more elements than the specified maximum. */
2058 if (NATNUMP (Vprint_length
)
2059 && XFASTINT (Vprint_length
) < size
)
2060 size
= XFASTINT (Vprint_length
);
2062 for (i
= 0; i
< size
; i
++)
2064 if (i
) PRINTCHAR (' ');
2065 tem
= XVECTOR (obj
)->contents
[i
];
2066 print_object (tem
, printcharfun
, escapeflag
);
2068 if (size
< real_size
)
2069 strout (" ...", 4, 4, printcharfun
, 0);
2076 switch (XMISCTYPE (obj
))
2078 case Lisp_Misc_Marker
:
2079 strout ("#<marker ", -1, -1, printcharfun
, 0);
2080 /* Do you think this is necessary? */
2081 if (XMARKER (obj
)->insertion_type
!= 0)
2082 strout ("(moves after insertion) ", -1, -1, printcharfun
, 0);
2083 if (! XMARKER (obj
)->buffer
)
2084 strout ("in no buffer", -1, -1, printcharfun
, 0);
2087 sprintf (buf
, "at %d", marker_position (obj
));
2088 strout (buf
, -1, -1, printcharfun
, 0);
2089 strout (" in ", -1, -1, printcharfun
, 0);
2090 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
2095 case Lisp_Misc_Overlay
:
2096 strout ("#<overlay ", -1, -1, printcharfun
, 0);
2097 if (! XMARKER (OVERLAY_START (obj
))->buffer
)
2098 strout ("in no buffer", -1, -1, printcharfun
, 0);
2101 sprintf (buf
, "from %d to %d in ",
2102 marker_position (OVERLAY_START (obj
)),
2103 marker_position (OVERLAY_END (obj
)));
2104 strout (buf
, -1, -1, printcharfun
, 0);
2105 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
2111 /* Remaining cases shouldn't happen in normal usage, but let's print
2112 them anyway for the benefit of the debugger. */
2113 case Lisp_Misc_Free
:
2114 strout ("#<misc free cell>", -1, -1, printcharfun
, 0);
2117 case Lisp_Misc_Intfwd
:
2118 sprintf (buf
, "#<intfwd to %ld>", (long) *XINTFWD (obj
)->intvar
);
2119 strout (buf
, -1, -1, printcharfun
, 0);
2122 case Lisp_Misc_Boolfwd
:
2123 sprintf (buf
, "#<boolfwd to %s>",
2124 (*XBOOLFWD (obj
)->boolvar
? "t" : "nil"));
2125 strout (buf
, -1, -1, printcharfun
, 0);
2128 case Lisp_Misc_Objfwd
:
2129 strout ("#<objfwd to ", -1, -1, printcharfun
, 0);
2130 print_object (*XOBJFWD (obj
)->objvar
, printcharfun
, escapeflag
);
2134 case Lisp_Misc_Buffer_Objfwd
:
2135 strout ("#<buffer_objfwd to ", -1, -1, printcharfun
, 0);
2136 print_object (PER_BUFFER_VALUE (current_buffer
,
2137 XBUFFER_OBJFWD (obj
)->offset
),
2138 printcharfun
, escapeflag
);
2142 case Lisp_Misc_Kboard_Objfwd
:
2143 strout ("#<kboard_objfwd to ", -1, -1, printcharfun
, 0);
2144 print_object (*(Lisp_Object
*) ((char *) current_kboard
2145 + XKBOARD_OBJFWD (obj
)->offset
),
2146 printcharfun
, escapeflag
);
2150 case Lisp_Misc_Buffer_Local_Value
:
2151 strout ("#<buffer_local_value ", -1, -1, printcharfun
, 0);
2152 goto do_buffer_local
;
2153 case Lisp_Misc_Some_Buffer_Local_Value
:
2154 strout ("#<some_buffer_local_value ", -1, -1, printcharfun
, 0);
2156 strout ("[realvalue] ", -1, -1, printcharfun
, 0);
2157 print_object (XBUFFER_LOCAL_VALUE (obj
)->realvalue
,
2158 printcharfun
, escapeflag
);
2159 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_buffer
)
2160 strout ("[local in buffer] ", -1, -1, printcharfun
, 0);
2162 strout ("[buffer] ", -1, -1, printcharfun
, 0);
2163 print_object (XBUFFER_LOCAL_VALUE (obj
)->buffer
,
2164 printcharfun
, escapeflag
);
2165 if (XBUFFER_LOCAL_VALUE (obj
)->check_frame
)
2167 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_frame
)
2168 strout ("[local in frame] ", -1, -1, printcharfun
, 0);
2170 strout ("[frame] ", -1, -1, printcharfun
, 0);
2171 print_object (XBUFFER_LOCAL_VALUE (obj
)->frame
,
2172 printcharfun
, escapeflag
);
2174 strout ("[alist-elt] ", -1, -1, printcharfun
, 0);
2175 print_object (XCAR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
2176 printcharfun
, escapeflag
);
2177 strout ("[default-value] ", -1, -1, printcharfun
, 0);
2178 print_object (XCDR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
2179 printcharfun
, escapeflag
);
2183 case Lisp_Misc_Save_Value
:
2184 strout ("#<save_value ", -1, -1, printcharfun
, 0);
2185 sprintf(buf
, "ptr=0x%08lx int=%d",
2186 (unsigned long) XSAVE_VALUE (obj
)->pointer
,
2187 XSAVE_VALUE (obj
)->integer
);
2188 strout (buf
, -1, -1, printcharfun
, 0);
2200 /* We're in trouble if this happens!
2201 Probably should just abort () */
2202 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
, 0);
2204 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2205 else if (VECTORLIKEP (obj
))
2206 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
2208 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2209 strout (buf
, -1, -1, printcharfun
, 0);
2210 strout (" Save your buffers immediately and please report this bug>",
2211 -1, -1, printcharfun
, 0);
2219 /* Print a description of INTERVAL using PRINTCHARFUN.
2220 This is part of printing a string that has text properties. */
2223 print_interval (interval
, printcharfun
)
2225 Lisp_Object printcharfun
;
2228 print_object (make_number (interval
->position
), printcharfun
, 1);
2230 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2233 print_object (interval
->plist
, printcharfun
, 1);
2240 Qtemp_buffer_setup_hook
= intern ("temp-buffer-setup-hook");
2241 staticpro (&Qtemp_buffer_setup_hook
);
2243 DEFVAR_LISP ("standard-output", &Vstandard_output
,
2244 doc
: /* Output stream `print' uses by default for outputting a character.
2245 This may be any function of one argument.
2246 It may also be a buffer (output is inserted before point)
2247 or a marker (output is inserted and the marker is advanced)
2248 or the symbol t (output appears in the echo area). */);
2249 Vstandard_output
= Qt
;
2250 Qstandard_output
= intern ("standard-output");
2251 staticpro (&Qstandard_output
);
2253 DEFVAR_LISP ("float-output-format", &Vfloat_output_format
,
2254 doc
: /* The format descriptor string used to print floats.
2255 This is a %-spec like those accepted by `printf' in C,
2256 but with some restrictions. It must start with the two characters `%.'.
2257 After that comes an integer precision specification,
2258 and then a letter which controls the format.
2259 The letters allowed are `e', `f' and `g'.
2260 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2261 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2262 Use `g' to choose the shorter of those two formats for the number at hand.
2263 The precision in any of these cases is the number of digits following
2264 the decimal point. With `f', a precision of 0 means to omit the
2265 decimal point. 0 is not allowed with `e' or `g'.
2267 A value of nil means to use the shortest notation
2268 that represents the number without losing information. */);
2269 Vfloat_output_format
= Qnil
;
2270 Qfloat_output_format
= intern ("float-output-format");
2271 staticpro (&Qfloat_output_format
);
2273 DEFVAR_LISP ("print-length", &Vprint_length
,
2274 doc
: /* Maximum length of list to print before abbreviating.
2275 A value of nil means no limit. See also `eval-expression-print-length'. */);
2276 Vprint_length
= Qnil
;
2278 DEFVAR_LISP ("print-level", &Vprint_level
,
2279 doc
: /* Maximum depth of list nesting to print before abbreviating.
2280 A value of nil means no limit. See also `eval-expression-print-level'. */);
2281 Vprint_level
= Qnil
;
2283 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines
,
2284 doc
: /* Non-nil means print newlines in strings as `\\n'.
2285 Also print formfeeds as `\\f'. */);
2286 print_escape_newlines
= 0;
2288 DEFVAR_BOOL ("print-escape-nonascii", &print_escape_nonascii
,
2289 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2290 \(OOO is the octal representation of the character code.)
2291 Only single-byte characters are affected, and only in `prin1'.
2292 When the output goes in a multibyte buffer, this feature is
2293 enabled regardless of the value of the variable. */);
2294 print_escape_nonascii
= 0;
2296 DEFVAR_BOOL ("print-escape-multibyte", &print_escape_multibyte
,
2297 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2298 \(XXXX is the hex representation of the character code.)
2299 This affects only `prin1'. */);
2300 print_escape_multibyte
= 0;
2302 DEFVAR_BOOL ("print-quoted", &print_quoted
,
2303 doc
: /* Non-nil means print quoted forms with reader syntax.
2304 I.e., (quote foo) prints as 'foo, (function foo) as #'foo, and backquoted
2305 forms print as in the new syntax. */);
2308 DEFVAR_LISP ("print-gensym", &Vprint_gensym
,
2309 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2310 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2311 When the uninterned symbol appears within a recursive data structure,
2312 and the symbol appears more than once, in addition use the #N# and #N=
2313 constructs as needed, so that multiple references to the same symbol are
2314 shared once again when the text is read back. */);
2315 Vprint_gensym
= Qnil
;
2317 DEFVAR_LISP ("print-circle", &Vprint_circle
,
2318 doc
: /* *Non-nil means print recursive structures using #N= and #N# syntax.
2319 If nil, printing proceeds recursively and may lead to
2320 `max-lisp-eval-depth' being exceeded or an error may occur:
2321 \"Apparently circular structure being printed.\" Also see
2322 `print-length' and `print-level'.
2323 If non-nil, shared substructures anywhere in the structure are printed
2324 with `#N=' before the first occurrence (in the order of the print
2325 representation) and `#N#' in place of each subsequent occurrence,
2326 where N is a positive decimal integer. */);
2327 Vprint_circle
= Qnil
;
2329 DEFVAR_LISP ("print-continuous-numbering", &Vprint_continuous_numbering
,
2330 doc
: /* *Non-nil means number continuously across print calls.
2331 This affects the numbers printed for #N= labels and #M# references.
2332 See also `print-circle', `print-gensym', and `print-number-table'.
2333 This variable should not be set with `setq'; bind it with a `let' instead. */);
2334 Vprint_continuous_numbering
= Qnil
;
2336 DEFVAR_LISP ("print-number-table", &Vprint_number_table
,
2337 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2338 The Lisp printer uses this vector to detect Lisp objects referenced more
2341 When you bind `print-continuous-numbering' to t, you should probably
2342 also bind `print-number-table' to nil. This ensures that the value of
2343 `print-number-table' can be garbage-collected once the printing is
2344 done. If all elements of `print-number-table' are nil, it means that
2345 the printing done so far has not found any shared structure or objects
2346 that need to be recorded in the table. */);
2347 Vprint_number_table
= Qnil
;
2349 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2350 staticpro (&Vprin1_to_string_buffer
);
2353 defsubr (&Sprin1_to_string
);
2354 defsubr (&Serror_message_string
);
2358 defsubr (&Swrite_char
);
2359 defsubr (&Sexternal_debugging_output
);
2360 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2361 defsubr (&Sredirect_debugging_output
);
2364 Qexternal_debugging_output
= intern ("external-debugging-output");
2365 staticpro (&Qexternal_debugging_output
);
2367 Qprint_escape_newlines
= intern ("print-escape-newlines");
2368 staticpro (&Qprint_escape_newlines
);
2370 Qprint_escape_multibyte
= intern ("print-escape-multibyte");
2371 staticpro (&Qprint_escape_multibyte
);
2373 Qprint_escape_nonascii
= intern ("print-escape-nonascii");
2374 staticpro (&Qprint_escape_nonascii
);
2376 defsubr (&Swith_output_to_temp_buffer
);
2379 /* arch-tag: bc797170-94ae-41de-86e3-75e20f8f7a39
2380 (do not change this comment) */