1 /* Lisp object printing and output streams.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999,
3 2000, 2001, 2003, 2004, 2005 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
20 Boston, MA 02110-1301, USA. */
32 #include "dispextern.h"
34 #include "intervals.h"
36 Lisp_Object Vstandard_output
, Qstandard_output
;
38 Lisp_Object Qtemp_buffer_setup_hook
;
40 /* These are used to print like we read. */
41 extern Lisp_Object Qbackquote
, Qcomma
, Qcomma_at
, Qcomma_dot
, Qfunction
;
43 Lisp_Object Vfloat_output_format
, Qfloat_output_format
;
45 /* Work around a problem that happens because math.h on hpux 7
46 defines two static variables--which, in Emacs, are not really static,
47 because `static' is defined as nothing. The problem is that they are
48 defined both here and in lread.c.
49 These macros prevent the name conflict. */
50 #if defined (HPUX) && !defined (HPUX8)
51 #define _MAXLDBL print_maxldbl
52 #define _NMAXLDBL print_nmaxldbl
61 /* Default to values appropriate for IEEE floating point. */
66 #define DBL_MANT_DIG 53
72 #define DBL_MIN 2.2250738585072014e-308
75 #ifdef DBL_MIN_REPLACEMENT
77 #define DBL_MIN DBL_MIN_REPLACEMENT
80 /* Define DOUBLE_DIGITS_BOUND, an upper bound on the number of decimal digits
81 needed to express a float without losing information.
82 The general-case formula is valid for the usual case, IEEE floating point,
83 but many compilers can't optimize the formula to an integer constant,
84 so make a special case for it. */
85 #if FLT_RADIX == 2 && DBL_MANT_DIG == 53
86 #define DOUBLE_DIGITS_BOUND 17 /* IEEE floating point */
88 #define DOUBLE_DIGITS_BOUND ((int) ceil (log10 (pow (FLT_RADIX, DBL_MANT_DIG))))
91 /* Avoid actual stack overflow in print. */
94 /* Nonzero if inside outputting backquote in old style. */
95 int old_backquote_output
;
97 /* Detect most circularities to print finite output. */
98 #define PRINT_CIRCLE 200
99 Lisp_Object being_printed
[PRINT_CIRCLE
];
101 /* When printing into a buffer, first we put the text in this
102 block, then insert it all at once. */
105 /* Size allocated in print_buffer. */
106 int print_buffer_size
;
107 /* Chars stored in print_buffer. */
108 int print_buffer_pos
;
109 /* Bytes stored in print_buffer. */
110 int print_buffer_pos_byte
;
112 /* Maximum length of list to print in full; noninteger means
113 effectively infinity */
115 Lisp_Object Vprint_length
;
117 /* Maximum depth of list to print in full; noninteger means
118 effectively infinity. */
120 Lisp_Object Vprint_level
;
122 /* Nonzero means print newlines in strings as \n. */
124 int print_escape_newlines
;
126 /* Nonzero means to print single-byte non-ascii characters in strings as
129 int print_escape_nonascii
;
131 /* Nonzero means to print multibyte characters in strings as hex escapes. */
133 int print_escape_multibyte
;
135 Lisp_Object Qprint_escape_newlines
;
136 Lisp_Object Qprint_escape_multibyte
, Qprint_escape_nonascii
;
138 /* Nonzero means print (quote foo) forms as 'foo, etc. */
142 /* Non-nil means print #: before uninterned symbols. */
144 Lisp_Object Vprint_gensym
;
146 /* Non-nil means print recursive structures using #n= and #n# syntax. */
148 Lisp_Object Vprint_circle
;
150 /* Non-nil means keep continuous number for #n= and #n# syntax
151 between several print functions. */
153 Lisp_Object Vprint_continuous_numbering
;
155 /* Vprint_number_table is a vector like [OBJ1 STAT1 OBJ2 STAT2 ...],
156 where OBJn are objects going to be printed, and STATn are their status,
157 which may be different meanings during process. See the comments of
158 the functions print and print_preprocess for details.
159 print_number_index keeps the last position the next object should be added,
160 twice of which is the actual vector position in Vprint_number_table. */
161 int print_number_index
;
162 Lisp_Object Vprint_number_table
;
164 /* PRINT_NUMBER_OBJECT returns the I'th object in Vprint_number_table TABLE.
165 PRINT_NUMBER_STATUS returns the status of the I'th object in TABLE.
166 See the comment of the variable Vprint_number_table. */
167 #define PRINT_NUMBER_OBJECT(table,i) XVECTOR ((table))->contents[(i) * 2]
168 #define PRINT_NUMBER_STATUS(table,i) XVECTOR ((table))->contents[(i) * 2 + 1]
170 /* Nonzero means print newline to stdout before next minibuffer message.
171 Defined in xdisp.c */
173 extern int noninteractive_need_newline
;
175 extern int minibuffer_auto_raise
;
177 #ifdef MAX_PRINT_CHARS
178 static int print_chars
;
179 static int max_print
;
180 #endif /* MAX_PRINT_CHARS */
182 void print_interval ();
185 /* Low level output routines for characters and strings */
187 /* Lisp functions to do output using a stream
188 must have the stream in a variable called printcharfun
189 and must start with PRINTPREPARE, end with PRINTFINISH,
190 and use PRINTDECLARE to declare common variables.
191 Use PRINTCHAR to output one character,
192 or call strout to output a block of characters. */
194 #define PRINTDECLARE \
195 struct buffer *old = current_buffer; \
196 int old_point = -1, start_point = -1; \
197 int old_point_byte = -1, start_point_byte = -1; \
198 int specpdl_count = SPECPDL_INDEX (); \
199 int free_print_buffer = 0; \
200 int multibyte = !NILP (current_buffer->enable_multibyte_characters); \
203 #define PRINTPREPARE \
204 original = printcharfun; \
205 if (NILP (printcharfun)) printcharfun = Qt; \
206 if (BUFFERP (printcharfun)) \
208 if (XBUFFER (printcharfun) != current_buffer) \
209 Fset_buffer (printcharfun); \
210 printcharfun = Qnil; \
212 if (MARKERP (printcharfun)) \
214 EMACS_INT marker_pos; \
215 if (!(XMARKER (printcharfun)->buffer)) \
216 error ("Marker does not point anywhere"); \
217 if (XMARKER (printcharfun)->buffer != current_buffer) \
218 set_buffer_internal (XMARKER (printcharfun)->buffer); \
219 marker_pos = marker_position (printcharfun); \
220 if (marker_pos < BEGV || marker_pos > ZV) \
221 error ("Marker is outside the accessible part of the buffer"); \
223 old_point_byte = PT_BYTE; \
224 SET_PT_BOTH (marker_pos, \
225 marker_byte_position (printcharfun)); \
227 start_point_byte = PT_BYTE; \
228 printcharfun = Qnil; \
230 if (NILP (printcharfun)) \
232 Lisp_Object string; \
233 if (NILP (current_buffer->enable_multibyte_characters) \
234 && ! print_escape_multibyte) \
235 specbind (Qprint_escape_multibyte, Qt); \
236 if (! NILP (current_buffer->enable_multibyte_characters) \
237 && ! print_escape_nonascii) \
238 specbind (Qprint_escape_nonascii, Qt); \
239 if (print_buffer != 0) \
241 string = make_string_from_bytes (print_buffer, \
243 print_buffer_pos_byte); \
244 record_unwind_protect (print_unwind, string); \
248 print_buffer_size = 1000; \
249 print_buffer = (char *) xmalloc (print_buffer_size); \
250 free_print_buffer = 1; \
252 print_buffer_pos = 0; \
253 print_buffer_pos_byte = 0; \
255 if (EQ (printcharfun, Qt) && ! noninteractive) \
256 setup_echo_area_for_printing (multibyte);
258 #define PRINTFINISH \
259 if (NILP (printcharfun)) \
261 if (print_buffer_pos != print_buffer_pos_byte \
262 && NILP (current_buffer->enable_multibyte_characters)) \
264 unsigned char *temp \
265 = (unsigned char *) alloca (print_buffer_pos + 1); \
266 copy_text (print_buffer, temp, print_buffer_pos_byte, \
268 insert_1_both (temp, print_buffer_pos, \
269 print_buffer_pos, 0, 1, 0); \
272 insert_1_both (print_buffer, print_buffer_pos, \
273 print_buffer_pos_byte, 0, 1, 0); \
275 if (free_print_buffer) \
277 xfree (print_buffer); \
280 unbind_to (specpdl_count, Qnil); \
281 if (MARKERP (original)) \
282 set_marker_both (original, Qnil, PT, PT_BYTE); \
283 if (old_point >= 0) \
284 SET_PT_BOTH (old_point + (old_point >= start_point \
285 ? PT - start_point : 0), \
286 old_point_byte + (old_point_byte >= start_point_byte \
287 ? PT_BYTE - start_point_byte : 0)); \
288 if (old != current_buffer) \
289 set_buffer_internal (old);
291 #define PRINTCHAR(ch) printchar (ch, printcharfun)
293 /* This is used to restore the saved contents of print_buffer
294 when there is a recursive call to print. */
297 print_unwind (saved_text
)
298 Lisp_Object saved_text
;
300 bcopy (SDATA (saved_text
), print_buffer
, SCHARS (saved_text
));
305 /* Print character CH using method FUN. FUN nil means print to
306 print_buffer. FUN t means print to echo area or stdout if
307 non-interactive. If FUN is neither nil nor t, call FUN with CH as
315 #ifdef MAX_PRINT_CHARS
318 #endif /* MAX_PRINT_CHARS */
320 if (!NILP (fun
) && !EQ (fun
, Qt
))
321 call1 (fun
, make_number (ch
));
324 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
325 int len
= CHAR_STRING (ch
, str
);
331 if (print_buffer_pos_byte
+ len
>= print_buffer_size
)
332 print_buffer
= (char *) xrealloc (print_buffer
,
333 print_buffer_size
*= 2);
334 bcopy (str
, print_buffer
+ print_buffer_pos_byte
, len
);
335 print_buffer_pos
+= 1;
336 print_buffer_pos_byte
+= len
;
338 else if (noninteractive
)
340 fwrite (str
, 1, len
, stdout
);
341 noninteractive_need_newline
= 1;
346 = !NILP (current_buffer
->enable_multibyte_characters
);
348 setup_echo_area_for_printing (multibyte_p
);
350 message_dolog (str
, len
, 0, multibyte_p
);
356 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
357 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
358 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
359 print_buffer. PRINTCHARFUN t means output to the echo area or to
360 stdout if non-interactive. If neither nil nor t, call Lisp
361 function PRINTCHARFUN for each character printed. MULTIBYTE
362 non-zero means PTR contains multibyte characters. */
365 strout (ptr
, size
, size_byte
, printcharfun
, multibyte
)
368 Lisp_Object printcharfun
;
372 size_byte
= size
= strlen (ptr
);
374 if (NILP (printcharfun
))
376 if (print_buffer_pos_byte
+ size_byte
> print_buffer_size
)
378 print_buffer_size
= print_buffer_size
* 2 + size_byte
;
379 print_buffer
= (char *) xrealloc (print_buffer
,
382 bcopy (ptr
, print_buffer
+ print_buffer_pos_byte
, size_byte
);
383 print_buffer_pos
+= size
;
384 print_buffer_pos_byte
+= size_byte
;
386 #ifdef MAX_PRINT_CHARS
389 #endif /* MAX_PRINT_CHARS */
391 else if (noninteractive
&& EQ (printcharfun
, Qt
))
393 fwrite (ptr
, 1, size_byte
, stdout
);
394 noninteractive_need_newline
= 1;
396 else if (EQ (printcharfun
, Qt
))
398 /* Output to echo area. We're trying to avoid a little overhead
399 here, that's the reason we don't call printchar to do the
403 = !NILP (current_buffer
->enable_multibyte_characters
);
405 setup_echo_area_for_printing (multibyte_p
);
406 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
408 if (size
== size_byte
)
410 for (i
= 0; i
< size
; ++i
)
411 insert_char ((unsigned char )*ptr
++);
416 for (i
= 0; i
< size_byte
; i
+= len
)
418 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size_byte
- i
, len
);
423 #ifdef MAX_PRINT_CHARS
426 #endif /* MAX_PRINT_CHARS */
430 /* PRINTCHARFUN is a Lisp function. */
433 if (size
== size_byte
)
435 while (i
< size_byte
)
443 while (i
< size_byte
)
445 /* Here, we must convert each multi-byte form to the
446 corresponding character code before handing it to
449 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size_byte
- i
, len
);
457 /* Print the contents of a string STRING using PRINTCHARFUN.
458 It isn't safe to use strout in many cases,
459 because printing one char can relocate. */
462 print_string (string
, printcharfun
)
464 Lisp_Object printcharfun
;
466 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
470 if (STRING_MULTIBYTE (string
))
471 chars
= SCHARS (string
);
472 else if (EQ (printcharfun
, Qt
)
473 ? ! NILP (buffer_defaults
.enable_multibyte_characters
)
474 : ! NILP (current_buffer
->enable_multibyte_characters
))
476 /* If unibyte string STRING contains 8-bit codes, we must
477 convert STRING to a multibyte string containing the same
482 chars
= SBYTES (string
);
483 bytes
= parse_str_to_multibyte (SDATA (string
), chars
);
486 newstr
= make_uninit_multibyte_string (chars
, bytes
);
487 bcopy (SDATA (string
), SDATA (newstr
), chars
);
488 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
493 chars
= SBYTES (string
);
495 /* strout is safe for output to a frame (echo area) or to print_buffer. */
496 strout (SDATA (string
),
497 chars
, SBYTES (string
),
498 printcharfun
, STRING_MULTIBYTE (string
));
502 /* Otherwise, string may be relocated by printing one char.
503 So re-fetch the string address for each character. */
505 int size
= SCHARS (string
);
506 int size_byte
= SBYTES (string
);
509 if (size
== size_byte
)
510 for (i
= 0; i
< size
; i
++)
511 PRINTCHAR (SREF (string
, i
));
513 for (i
= 0; i
< size_byte
; )
515 /* Here, we must convert each multi-byte form to the
516 corresponding character code before handing it to PRINTCHAR. */
518 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
,
520 if (!CHAR_VALID_P (ch
, 0))
522 ch
= SREF (string
, i
);
532 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
533 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
534 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
535 (character
, printcharfun
)
536 Lisp_Object character
, printcharfun
;
540 if (NILP (printcharfun
))
541 printcharfun
= Vstandard_output
;
542 CHECK_NUMBER (character
);
544 PRINTCHAR (XINT (character
));
549 /* Used from outside of print.c to print a block of SIZE
550 single-byte chars at DATA on the default output stream.
551 Do not use this on the contents of a Lisp string. */
554 write_string (data
, size
)
559 Lisp_Object printcharfun
;
561 printcharfun
= Vstandard_output
;
564 strout (data
, size
, size
, printcharfun
, 0);
568 /* Used from outside of print.c to print a block of SIZE
569 single-byte chars at DATA on a specified stream PRINTCHARFUN.
570 Do not use this on the contents of a Lisp string. */
573 write_string_1 (data
, size
, printcharfun
)
576 Lisp_Object printcharfun
;
581 strout (data
, size
, size
, printcharfun
, 0);
587 temp_output_buffer_setup (bufname
)
590 int count
= SPECPDL_INDEX ();
591 register struct buffer
*old
= current_buffer
;
592 register Lisp_Object buf
;
594 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
596 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
598 Fkill_all_local_variables ();
599 delete_all_overlays (current_buffer
);
600 current_buffer
->directory
= old
->directory
;
601 current_buffer
->read_only
= Qnil
;
602 current_buffer
->filename
= Qnil
;
603 current_buffer
->undo_list
= Qt
;
604 eassert (current_buffer
->overlays_before
== NULL
);
605 eassert (current_buffer
->overlays_after
== NULL
);
606 current_buffer
->enable_multibyte_characters
607 = buffer_defaults
.enable_multibyte_characters
;
608 specbind (Qinhibit_read_only
, Qt
);
609 specbind (Qinhibit_modification_hooks
, Qt
);
611 XSETBUFFER (buf
, current_buffer
);
613 Frun_hooks (1, &Qtemp_buffer_setup_hook
);
615 unbind_to (count
, Qnil
);
617 specbind (Qstandard_output
, buf
);
621 internal_with_output_to_temp_buffer (bufname
, function
, args
)
623 Lisp_Object (*function
) P_ ((Lisp_Object
));
626 int count
= SPECPDL_INDEX ();
627 Lisp_Object buf
, val
;
631 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
632 temp_output_buffer_setup (bufname
);
633 buf
= Vstandard_output
;
636 val
= (*function
) (args
);
639 temp_output_buffer_show (buf
);
642 return unbind_to (count
, val
);
645 DEFUN ("with-output-to-temp-buffer",
646 Fwith_output_to_temp_buffer
, Swith_output_to_temp_buffer
,
648 doc
: /* Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
649 The buffer is cleared out initially, and marked as unmodified when done.
650 All output done by BODY is inserted in that buffer by default.
651 The buffer is displayed in another window, but not selected.
652 The value of the last form in BODY is returned.
653 If BODY does not finish normally, the buffer BUFNAME is not displayed.
655 The hook `temp-buffer-setup-hook' is run before BODY,
656 with the buffer BUFNAME temporarily current.
657 The hook `temp-buffer-show-hook' is run after the buffer is displayed,
658 with the buffer temporarily current, and the window that was used
659 to display it temporarily selected.
661 If variable `temp-buffer-show-function' is non-nil, call it at the end
662 to get the buffer displayed instead of just displaying the non-selected
663 buffer and calling the hook. It gets one argument, the buffer to display.
665 usage: (with-output-to-temp-buffer BUFNAME BODY ...) */)
671 int count
= SPECPDL_INDEX ();
672 Lisp_Object buf
, val
;
675 name
= Feval (Fcar (args
));
677 temp_output_buffer_setup (SDATA (name
));
678 buf
= Vstandard_output
;
681 val
= Fprogn (XCDR (args
));
684 temp_output_buffer_show (buf
);
687 return unbind_to (count
, val
);
691 static void print ();
692 static void print_preprocess ();
693 static void print_preprocess_string ();
694 static void print_object ();
696 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
697 doc
: /* Output a newline to stream PRINTCHARFUN.
698 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
700 Lisp_Object printcharfun
;
704 if (NILP (printcharfun
))
705 printcharfun
= Vstandard_output
;
712 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
713 doc
: /* Output the printed representation of OBJECT, any Lisp object.
714 Quoting characters are printed when needed to make output that `read'
715 can handle, whenever this is possible. For complex objects, the behavior
716 is controlled by `print-level' and `print-length', which see.
718 OBJECT is any of the Lisp data types: a number, a string, a symbol,
719 a list, a buffer, a window, a frame, etc.
721 A printed representation of an object is text which describes that object.
723 Optional argument PRINTCHARFUN is the output stream, which can be one
726 - a buffer, in which case output is inserted into that buffer at point;
727 - a marker, in which case output is inserted at marker's position;
728 - a function, in which case that function is called once for each
729 character of OBJECT's printed representation;
730 - a symbol, in which case that symbol's function definition is called; or
731 - t, in which case the output is displayed in the echo area.
733 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
735 (object
, printcharfun
)
736 Lisp_Object object
, printcharfun
;
740 #ifdef MAX_PRINT_CHARS
742 #endif /* MAX_PRINT_CHARS */
743 if (NILP (printcharfun
))
744 printcharfun
= Vstandard_output
;
746 print (object
, printcharfun
, 1);
751 /* a buffer which is used to hold output being built by prin1-to-string */
752 Lisp_Object Vprin1_to_string_buffer
;
754 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
755 doc
: /* Return a string containing the printed representation of OBJECT.
756 OBJECT can be any Lisp object. This function outputs quoting characters
757 when necessary to make output that `read' can handle, whenever possible,
758 unless the optional second argument NOESCAPE is non-nil.
760 OBJECT is any of the Lisp data types: a number, a string, a symbol,
761 a list, a buffer, a window, a frame, etc.
763 A printed representation of an object is text which describes that object. */)
765 Lisp_Object object
, noescape
;
767 Lisp_Object printcharfun
;
768 /* struct gcpro gcpro1, gcpro2; */
769 Lisp_Object save_deactivate_mark
;
770 int count
= specpdl_ptr
- specpdl
;
771 struct buffer
*previous
;
773 specbind (Qinhibit_modification_hooks
, Qt
);
778 /* Save and restore this--we are altering a buffer
779 but we don't want to deactivate the mark just for that.
780 No need for specbind, since errors deactivate the mark. */
781 save_deactivate_mark
= Vdeactivate_mark
;
782 /* GCPRO2 (object, save_deactivate_mark); */
785 printcharfun
= Vprin1_to_string_buffer
;
787 print (object
, printcharfun
, NILP (noescape
));
788 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
792 previous
= current_buffer
;
793 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
794 object
= Fbuffer_string ();
795 if (SBYTES (object
) == SCHARS (object
))
796 STRING_SET_UNIBYTE (object
);
798 /* Note that this won't make prepare_to_modify_buffer call
799 ask-user-about-supersession-threat because this buffer
800 does not visit a file. */
802 set_buffer_internal (previous
);
804 Vdeactivate_mark
= save_deactivate_mark
;
808 return unbind_to (count
, object
);
811 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
812 doc
: /* Output the printed representation of OBJECT, any Lisp object.
813 No quoting characters are used; no delimiters are printed around
814 the contents of strings.
816 OBJECT is any of the Lisp data types: a number, a string, a symbol,
817 a list, a buffer, a window, a frame, etc.
819 A printed representation of an object is text which describes that object.
821 Optional argument PRINTCHARFUN is the output stream, which can be one
824 - a buffer, in which case output is inserted into that buffer at point;
825 - a marker, in which case output is inserted at marker's position;
826 - a function, in which case that function is called once for each
827 character of OBJECT's printed representation;
828 - a symbol, in which case that symbol's function definition is called; or
829 - t, in which case the output is displayed in the echo area.
831 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
833 (object
, printcharfun
)
834 Lisp_Object object
, printcharfun
;
838 if (NILP (printcharfun
))
839 printcharfun
= Vstandard_output
;
841 print (object
, printcharfun
, 0);
846 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
847 doc
: /* Output the printed representation of OBJECT, with newlines around it.
848 Quoting characters are printed when needed to make output that `read'
849 can handle, whenever this is possible. For complex objects, the behavior
850 is controlled by `print-level' and `print-length', which see.
852 OBJECT is any of the Lisp data types: a number, a string, a symbol,
853 a list, a buffer, a window, a frame, etc.
855 A printed representation of an object is text which describes that object.
857 Optional argument PRINTCHARFUN is the output stream, which can be one
860 - a buffer, in which case output is inserted into that buffer at point;
861 - a marker, in which case output is inserted at marker's position;
862 - a function, in which case that function is called once for each
863 character of OBJECT's printed representation;
864 - a symbol, in which case that symbol's function definition is called; or
865 - t, in which case the output is displayed in the echo area.
867 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
869 (object
, printcharfun
)
870 Lisp_Object object
, printcharfun
;
875 #ifdef MAX_PRINT_CHARS
877 max_print
= MAX_PRINT_CHARS
;
878 #endif /* MAX_PRINT_CHARS */
879 if (NILP (printcharfun
))
880 printcharfun
= Vstandard_output
;
884 print (object
, printcharfun
, 1);
887 #ifdef MAX_PRINT_CHARS
890 #endif /* MAX_PRINT_CHARS */
895 /* The subroutine object for external-debugging-output is kept here
896 for the convenience of the debugger. */
897 Lisp_Object Qexternal_debugging_output
;
899 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
900 doc
: /* Write CHARACTER to stderr.
901 You can call print while debugging emacs, and pass it this function
902 to make it write to the debugging output. */)
904 Lisp_Object character
;
906 CHECK_NUMBER (character
);
907 putc (XINT (character
), stderr
);
910 /* Send the output to a debugger (nothing happens if there isn't one). */
912 char buf
[2] = {(char) XINT (character
), '\0'};
913 OutputDebugString (buf
);
921 #if defined(GNU_LINUX)
923 /* This functionality is not vitally important in general, so we rely on
924 non-portable ability to use stderr as lvalue. */
926 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
928 FILE *initial_stderr_stream
= NULL
;
930 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
932 "FDebug output file: \nP",
933 doc
: /* Redirect debugging output (stderr stream) to file FILE.
934 If FILE is nil, reset target to the initial stderr stream.
935 Optional arg APPEND non-nil (interactively, with prefix arg) means
936 append to existing target file. */)
938 Lisp_Object file
, append
;
940 if (initial_stderr_stream
!= NULL
)
942 stderr
= initial_stderr_stream
;
943 initial_stderr_stream
= NULL
;
947 file
= Fexpand_file_name (file
, Qnil
);
948 initial_stderr_stream
= stderr
;
949 stderr
= fopen(SDATA (file
), NILP (append
) ? "w" : "a");
952 stderr
= initial_stderr_stream
;
953 initial_stderr_stream
= NULL
;
954 report_file_error ("Cannot open debugging output stream",
960 #endif /* GNU_LINUX */
963 /* This is the interface for debugging printing. */
969 Fprin1 (arg
, Qexternal_debugging_output
);
970 fprintf (stderr
, "\r\n");
973 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
975 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
976 See Info anchor `(elisp)Definition of signal' for some details on how this
977 error message is constructed. */)
981 struct buffer
*old
= current_buffer
;
985 /* If OBJ is (error STRING), just return STRING.
986 That is not only faster, it also avoids the need to allocate
987 space here when the error is due to memory full. */
988 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
989 && CONSP (XCDR (obj
))
990 && STRINGP (XCAR (XCDR (obj
)))
991 && NILP (XCDR (XCDR (obj
))))
992 return XCAR (XCDR (obj
));
994 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
996 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
997 value
= Fbuffer_string ();
1001 set_buffer_internal (old
);
1007 /* Print an error message for the error DATA onto Lisp output stream
1008 STREAM (suitable for the print functions). */
1011 print_error_message (data
, stream
, context
, caller
)
1012 Lisp_Object data
, stream
;
1016 Lisp_Object errname
, errmsg
, file_error
, tail
;
1017 struct gcpro gcpro1
;
1021 write_string_1 (context
, -1, stream
);
1023 /* If we know from where the error was signaled, show it in
1025 if (!NILP (caller
) && SYMBOLP (caller
))
1027 const char *name
= SDATA (SYMBOL_NAME (caller
));
1028 message_dolog (name
, strlen (name
), 0, 0);
1029 message_dolog (": ", 2, 0, 0);
1032 errname
= Fcar (data
);
1034 if (EQ (errname
, Qerror
))
1039 errmsg
= Fcar (data
);
1044 Lisp_Object error_conditions
;
1045 errmsg
= Fget (errname
, Qerror_message
);
1046 error_conditions
= Fget (errname
, Qerror_conditions
);
1047 file_error
= Fmemq (Qfile_error
, error_conditions
);
1050 /* Print an error message including the data items. */
1052 tail
= Fcdr_safe (data
);
1055 /* For file-error, make error message by concatenating
1056 all the data items. They are all strings. */
1057 if (!NILP (file_error
) && CONSP (tail
))
1058 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
1060 if (STRINGP (errmsg
))
1061 Fprinc (errmsg
, stream
);
1063 write_string_1 ("peculiar error", -1, stream
);
1065 for (i
= 0; CONSP (tail
); tail
= XCDR (tail
), i
++)
1069 write_string_1 (i
? ", " : ": ", 2, stream
);
1071 if (!NILP (file_error
) || EQ (errname
, Qend_of_file
))
1072 Fprinc (obj
, stream
);
1074 Fprin1 (obj
, stream
);
1083 * The buffer should be at least as large as the max string size of the
1084 * largest float, printed in the biggest notation. This is undoubtedly
1085 * 20d float_output_format, with the negative of the C-constant "HUGE"
1088 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
1090 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
1091 * case of -1e307 in 20d float_output_format. What is one to do (short of
1092 * re-writing _doprnt to be more sane)?
1097 float_to_string (buf
, data
)
1104 /* Check for plus infinity in a way that won't lose
1105 if there is no plus infinity. */
1106 if (data
== data
/ 2 && data
> 1.0)
1108 strcpy (buf
, "1.0e+INF");
1111 /* Likewise for minus infinity. */
1112 if (data
== data
/ 2 && data
< -1.0)
1114 strcpy (buf
, "-1.0e+INF");
1117 /* Check for NaN in a way that won't fail if there are no NaNs. */
1118 if (! (data
* 0.0 >= 0.0))
1120 /* Prepend "-" if the NaN's sign bit is negative.
1121 The sign bit of a double is the bit that is 1 in -0.0. */
1123 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
1125 u_minus_zero
.d
= - 0.0;
1126 for (i
= 0; i
< sizeof (double); i
++)
1127 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
1133 strcpy (buf
, "0.0e+NaN");
1137 if (NILP (Vfloat_output_format
)
1138 || !STRINGP (Vfloat_output_format
))
1141 /* Generate the fewest number of digits that represent the
1142 floating point value without losing information.
1143 The following method is simple but a bit slow.
1144 For ideas about speeding things up, please see:
1146 Guy L Steele Jr & Jon L White, How to print floating-point numbers
1147 accurately. SIGPLAN notices 25, 6 (June 1990), 112-126.
1149 Robert G Burger & R Kent Dybvig, Printing floating point numbers
1150 quickly and accurately, SIGPLAN notices 31, 5 (May 1996), 108-116. */
1152 width
= fabs (data
) < DBL_MIN
? 1 : DBL_DIG
;
1154 sprintf (buf
, "%.*g", width
, data
);
1155 while (width
++ < DOUBLE_DIGITS_BOUND
&& atof (buf
) != data
);
1157 else /* oink oink */
1159 /* Check that the spec we have is fully valid.
1160 This means not only valid for printf,
1161 but meant for floats, and reasonable. */
1162 cp
= SDATA (Vfloat_output_format
);
1171 /* Check the width specification. */
1173 if ('0' <= *cp
&& *cp
<= '9')
1177 width
= (width
* 10) + (*cp
++ - '0');
1178 while (*cp
>= '0' && *cp
<= '9');
1180 /* A precision of zero is valid only for %f. */
1182 || (width
== 0 && *cp
!= 'f'))
1186 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1192 sprintf (buf
, SDATA (Vfloat_output_format
), data
);
1195 /* Make sure there is a decimal point with digit after, or an
1196 exponent, so that the value is readable as a float. But don't do
1197 this with "%.0f"; it's valid for that not to produce a decimal
1198 point. Note that width can be 0 only for %.0f. */
1201 for (cp
= buf
; *cp
; cp
++)
1202 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1205 if (*cp
== '.' && cp
[1] == 0)
1222 print (obj
, printcharfun
, escapeflag
)
1224 register Lisp_Object printcharfun
;
1227 old_backquote_output
= 0;
1229 /* Reset print_number_index and Vprint_number_table only when
1230 the variable Vprint_continuous_numbering is nil. Otherwise,
1231 the values of these variables will be kept between several
1233 if (NILP (Vprint_continuous_numbering
))
1235 print_number_index
= 0;
1236 Vprint_number_table
= Qnil
;
1239 /* Construct Vprint_number_table for print-gensym and print-circle. */
1240 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1242 int i
, start
, index
;
1243 start
= index
= print_number_index
;
1244 /* Construct Vprint_number_table.
1245 This increments print_number_index for the objects added. */
1247 print_preprocess (obj
);
1249 /* Remove unnecessary objects, which appear only once in OBJ;
1250 that is, whose status is Qnil. Compactify the necessary objects. */
1251 for (i
= start
; i
< print_number_index
; i
++)
1252 if (!NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1254 PRINT_NUMBER_OBJECT (Vprint_number_table
, index
)
1255 = PRINT_NUMBER_OBJECT (Vprint_number_table
, i
);
1259 /* Clear out objects outside the active part of the table. */
1260 for (i
= index
; i
< print_number_index
; i
++)
1261 PRINT_NUMBER_OBJECT (Vprint_number_table
, i
) = Qnil
;
1263 /* Reset the status field for the next print step. Now this
1264 field means whether the object has already been printed. */
1265 for (i
= start
; i
< print_number_index
; i
++)
1266 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qnil
;
1268 print_number_index
= index
;
1272 print_object (obj
, printcharfun
, escapeflag
);
1275 /* Construct Vprint_number_table according to the structure of OBJ.
1276 OBJ itself and all its elements will be added to Vprint_number_table
1277 recursively if it is a list, vector, compiled function, char-table,
1278 string (its text properties will be traced), or a symbol that has
1279 no obarray (this is for the print-gensym feature).
1280 The status fields of Vprint_number_table mean whether each object appears
1281 more than once in OBJ: Qnil at the first time, and Qt after that . */
1283 print_preprocess (obj
)
1289 Lisp_Object halftail
;
1291 /* Give up if we go so deep that print_object will get an error. */
1292 /* See similar code in print_object. */
1293 if (print_depth
>= PRINT_CIRCLE
)
1296 /* Avoid infinite recursion for circular nested structure
1297 in the case where Vprint_circle is nil. */
1298 if (NILP (Vprint_circle
))
1300 for (i
= 0; i
< print_depth
; i
++)
1301 if (EQ (obj
, being_printed
[i
]))
1303 being_printed
[print_depth
] = obj
;
1310 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1311 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
)
1312 || (! NILP (Vprint_gensym
)
1314 && !SYMBOL_INTERNED_P (obj
)))
1316 /* In case print-circle is nil and print-gensym is t,
1317 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1318 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1320 for (i
= 0; i
< print_number_index
; i
++)
1321 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
), obj
))
1323 /* OBJ appears more than once. Let's remember that. */
1324 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1328 /* OBJ is not yet recorded. Let's add to the table. */
1329 if (print_number_index
== 0)
1331 /* Initialize the table. */
1332 Vprint_number_table
= Fmake_vector (make_number (40), Qnil
);
1334 else if (XVECTOR (Vprint_number_table
)->size
== print_number_index
* 2)
1336 /* Reallocate the table. */
1337 int i
= print_number_index
* 4;
1338 Lisp_Object old_table
= Vprint_number_table
;
1339 Vprint_number_table
= Fmake_vector (make_number (i
), Qnil
);
1340 for (i
= 0; i
< print_number_index
; i
++)
1342 PRINT_NUMBER_OBJECT (Vprint_number_table
, i
)
1343 = PRINT_NUMBER_OBJECT (old_table
, i
);
1344 PRINT_NUMBER_STATUS (Vprint_number_table
, i
)
1345 = PRINT_NUMBER_STATUS (old_table
, i
);
1348 PRINT_NUMBER_OBJECT (Vprint_number_table
, print_number_index
) = obj
;
1349 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1350 always print the gensym with a number. This is a special for
1351 the lisp function byte-compile-output-docform. */
1352 if (!NILP (Vprint_continuous_numbering
)
1354 && !SYMBOL_INTERNED_P (obj
))
1355 PRINT_NUMBER_STATUS (Vprint_number_table
, print_number_index
) = Qt
;
1356 print_number_index
++;
1359 switch (XGCTYPE (obj
))
1362 /* A string may have text properties, which can be circular. */
1363 traverse_intervals_noorder (STRING_INTERVALS (obj
),
1364 print_preprocess_string
, Qnil
);
1368 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1369 just as in print_object. */
1370 if (loop_count
&& EQ (obj
, halftail
))
1372 print_preprocess (XCAR (obj
));
1375 if (!(loop_count
& 1))
1376 halftail
= XCDR (halftail
);
1379 case Lisp_Vectorlike
:
1380 size
= XVECTOR (obj
)->size
;
1381 if (size
& PSEUDOVECTOR_FLAG
)
1382 size
&= PSEUDOVECTOR_SIZE_MASK
;
1383 for (i
= 0; i
< size
; i
++)
1384 print_preprocess (XVECTOR (obj
)->contents
[i
]);
1395 print_preprocess_string (interval
, arg
)
1399 print_preprocess (interval
->plist
);
1403 print_object (obj
, printcharfun
, escapeflag
)
1405 register Lisp_Object printcharfun
;
1412 /* Detect circularities and truncate them. */
1413 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1414 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
)
1415 || (! NILP (Vprint_gensym
)
1417 && !SYMBOL_INTERNED_P (obj
)))
1419 if (NILP (Vprint_circle
) && NILP (Vprint_gensym
))
1421 /* Simple but incomplete way. */
1423 for (i
= 0; i
< print_depth
; i
++)
1424 if (EQ (obj
, being_printed
[i
]))
1426 sprintf (buf
, "#%d", i
);
1427 strout (buf
, -1, -1, printcharfun
, 0);
1430 being_printed
[print_depth
] = obj
;
1434 /* With the print-circle feature. */
1436 for (i
= 0; i
< print_number_index
; i
++)
1437 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
), obj
))
1439 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1441 /* Add a prefix #n= if OBJ has not yet been printed;
1442 that is, its status field is nil. */
1443 sprintf (buf
, "#%d=", i
+ 1);
1444 strout (buf
, -1, -1, printcharfun
, 0);
1445 /* OBJ is going to be printed. Set the status to t. */
1446 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1451 /* Just print #n# if OBJ has already been printed. */
1452 sprintf (buf
, "#%d#", i
+ 1);
1453 strout (buf
, -1, -1, printcharfun
, 0);
1462 /* See similar code in print_preprocess. */
1463 if (print_depth
> PRINT_CIRCLE
)
1464 error ("Apparently circular structure being printed");
1465 #ifdef MAX_PRINT_CHARS
1466 if (max_print
&& print_chars
> max_print
)
1471 #endif /* MAX_PRINT_CHARS */
1473 switch (XGCTYPE (obj
))
1476 if (sizeof (int) == sizeof (EMACS_INT
))
1477 sprintf (buf
, "%d", XINT (obj
));
1478 else if (sizeof (long) == sizeof (EMACS_INT
))
1479 sprintf (buf
, "%ld", (long) XINT (obj
));
1482 strout (buf
, -1, -1, printcharfun
, 0);
1487 char pigbuf
[350]; /* see comments in float_to_string */
1489 float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1490 strout (pigbuf
, -1, -1, printcharfun
, 0);
1496 print_string (obj
, printcharfun
);
1499 register int i
, i_byte
;
1500 struct gcpro gcpro1
;
1503 /* 1 means we must ensure that the next character we output
1504 cannot be taken as part of a hex character escape. */
1505 int need_nonhex
= 0;
1506 int multibyte
= STRING_MULTIBYTE (obj
);
1510 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1518 size_byte
= SBYTES (obj
);
1520 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1522 /* Here, we must convert each multi-byte form to the
1523 corresponding character code before handing it to PRINTCHAR. */
1529 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
,
1530 size_byte
- i_byte
, len
);
1531 if (CHAR_VALID_P (c
, 0))
1541 if (c
== '\n' && print_escape_newlines
)
1546 else if (c
== '\f' && print_escape_newlines
)
1552 && ! ASCII_BYTE_P (c
)
1553 && (SINGLE_BYTE_CHAR_P (c
) || print_escape_multibyte
))
1555 /* When multibyte is disabled,
1556 print multibyte string chars using hex escapes.
1557 For a char code that could be in a unibyte string,
1558 when found in a multibyte string, always use a hex escape
1559 so it reads back as multibyte. */
1560 unsigned char outbuf
[50];
1561 sprintf (outbuf
, "\\x%x", c
);
1562 strout (outbuf
, -1, -1, printcharfun
, 0);
1565 else if (! multibyte
1566 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1567 && print_escape_nonascii
)
1569 /* When printing in a multibyte buffer
1570 or when explicitly requested,
1571 print single-byte non-ASCII string chars
1572 using octal escapes. */
1573 unsigned char outbuf
[5];
1574 sprintf (outbuf
, "\\%03o", c
);
1575 strout (outbuf
, -1, -1, printcharfun
, 0);
1579 /* If we just had a hex escape, and this character
1580 could be taken as part of it,
1581 output `\ ' to prevent that. */
1585 if ((c
>= 'a' && c
<= 'f')
1586 || (c
>= 'A' && c
<= 'F')
1587 || (c
>= '0' && c
<= '9'))
1588 strout ("\\ ", -1, -1, printcharfun
, 0);
1591 if (c
== '\"' || c
== '\\')
1598 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1600 traverse_intervals (STRING_INTERVALS (obj
),
1601 0, print_interval
, printcharfun
);
1611 register int confusing
;
1612 register unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1613 register unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1615 int i
, i_byte
, size_byte
;
1618 name
= SYMBOL_NAME (obj
);
1620 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1623 /* If symbol name begins with a digit, and ends with a digit,
1624 and contains nothing but digits and `e', it could be treated
1625 as a number. So set CONFUSING.
1627 Symbols that contain periods could also be taken as numbers,
1628 but periods are always escaped, so we don't have to worry
1630 else if (*p
>= '0' && *p
<= '9'
1631 && end
[-1] >= '0' && end
[-1] <= '9')
1633 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1634 /* Needed for \2e10. */
1637 confusing
= (end
== p
);
1642 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1648 size_byte
= SBYTES (name
);
1650 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1652 /* Here, we must convert each multi-byte form to the
1653 corresponding character code before handing it to PRINTCHAR. */
1654 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1659 if (c
== '\"' || c
== '\\' || c
== '\''
1660 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1661 || c
== ',' || c
=='.' || c
== '`'
1662 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1664 PRINTCHAR ('\\'), confusing
= 0;
1672 /* If deeper than spec'd depth, print placeholder. */
1673 if (INTEGERP (Vprint_level
)
1674 && print_depth
> XINT (Vprint_level
))
1675 strout ("...", -1, -1, printcharfun
, 0);
1676 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1677 && (EQ (XCAR (obj
), Qquote
)))
1680 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1682 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1683 && (EQ (XCAR (obj
), Qfunction
)))
1687 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1689 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1690 && ! old_backquote_output
1691 && ((EQ (XCAR (obj
), Qbackquote
)
1692 || EQ (XCAR (obj
), Qcomma
)
1693 || EQ (XCAR (obj
), Qcomma_at
)
1694 || EQ (XCAR (obj
), Qcomma_dot
))))
1696 print_object (XCAR (obj
), printcharfun
, 0);
1697 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1703 /* If the first element is a backquote form,
1704 print it old-style so it won't be misunderstood. */
1705 if (print_quoted
&& CONSP (XCAR (obj
))
1706 && CONSP (XCDR (XCAR (obj
)))
1707 && NILP (XCDR (XCDR (XCAR (obj
))))
1708 && EQ (XCAR (XCAR (obj
)), Qbackquote
))
1714 print_object (Qbackquote
, printcharfun
, 0);
1717 ++old_backquote_output
;
1718 print_object (XCAR (XCDR (tem
)), printcharfun
, 0);
1719 --old_backquote_output
;
1726 int print_length
, i
;
1727 Lisp_Object halftail
= obj
;
1729 /* Negative values of print-length are invalid in CL.
1730 Treat them like nil, as CMUCL does. */
1731 if (NATNUMP (Vprint_length
))
1732 print_length
= XFASTINT (Vprint_length
);
1739 /* Detect circular list. */
1740 if (NILP (Vprint_circle
))
1742 /* Simple but imcomplete way. */
1743 if (i
!= 0 && EQ (obj
, halftail
))
1745 sprintf (buf
, " . #%d", i
/ 2);
1746 strout (buf
, -1, -1, printcharfun
, 0);
1752 /* With the print-circle feature. */
1756 for (i
= 0; i
< print_number_index
; i
++)
1757 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
),
1760 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1762 strout (" . ", 3, 3, printcharfun
, 0);
1763 print_object (obj
, printcharfun
, escapeflag
);
1767 sprintf (buf
, " . #%d#", i
+ 1);
1768 strout (buf
, -1, -1, printcharfun
, 0);
1778 if (print_length
&& i
> print_length
)
1780 strout ("...", 3, 3, printcharfun
, 0);
1784 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1788 halftail
= XCDR (halftail
);
1792 /* OBJ non-nil here means it's the end of a dotted list. */
1795 strout (" . ", 3, 3, printcharfun
, 0);
1796 print_object (obj
, printcharfun
, escapeflag
);
1804 case Lisp_Vectorlike
:
1809 strout ("#<process ", -1, -1, printcharfun
, 0);
1810 print_string (XPROCESS (obj
)->name
, printcharfun
);
1814 print_string (XPROCESS (obj
)->name
, printcharfun
);
1816 else if (BOOL_VECTOR_P (obj
))
1819 register unsigned char c
;
1820 struct gcpro gcpro1
;
1822 = ((XBOOL_VECTOR (obj
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
1823 / BOOL_VECTOR_BITS_PER_CHAR
);
1829 sprintf (buf
, "%ld", (long) XBOOL_VECTOR (obj
)->size
);
1830 strout (buf
, -1, -1, printcharfun
, 0);
1833 /* Don't print more characters than the specified maximum.
1834 Negative values of print-length are invalid. Treat them
1835 like a print-length of nil. */
1836 if (NATNUMP (Vprint_length
)
1837 && XFASTINT (Vprint_length
) < size_in_chars
)
1838 size_in_chars
= XFASTINT (Vprint_length
);
1840 for (i
= 0; i
< size_in_chars
; i
++)
1843 c
= XBOOL_VECTOR (obj
)->data
[i
];
1844 if (c
== '\n' && print_escape_newlines
)
1849 else if (c
== '\f' && print_escape_newlines
)
1854 else if (c
> '\177')
1856 /* Use octal escapes to avoid encoding issues. */
1858 PRINTCHAR ('0' + ((c
>> 6) & 3));
1859 PRINTCHAR ('0' + ((c
>> 3) & 7));
1860 PRINTCHAR ('0' + (c
& 7));
1864 if (c
== '\"' || c
== '\\')
1873 else if (SUBRP (obj
))
1875 strout ("#<subr ", -1, -1, printcharfun
, 0);
1876 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
, 0);
1879 else if (WINDOWP (obj
))
1881 strout ("#<window ", -1, -1, printcharfun
, 0);
1882 sprintf (buf
, "%ld", (long) XFASTINT (XWINDOW (obj
)->sequence_number
));
1883 strout (buf
, -1, -1, printcharfun
, 0);
1884 if (!NILP (XWINDOW (obj
)->buffer
))
1886 strout (" on ", -1, -1, printcharfun
, 0);
1887 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1891 else if (HASH_TABLE_P (obj
))
1893 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1894 strout ("#<hash-table", -1, -1, printcharfun
, 0);
1895 if (SYMBOLP (h
->test
))
1899 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
, 0);
1901 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
, 0);
1903 sprintf (buf
, "%ld/%ld", (long) XFASTINT (h
->count
),
1904 (long) XVECTOR (h
->next
)->size
);
1905 strout (buf
, -1, -1, printcharfun
, 0);
1907 sprintf (buf
, " 0x%lx", (unsigned long) h
);
1908 strout (buf
, -1, -1, printcharfun
, 0);
1911 else if (BUFFERP (obj
))
1913 if (NILP (XBUFFER (obj
)->name
))
1914 strout ("#<killed buffer>", -1, -1, printcharfun
, 0);
1915 else if (escapeflag
)
1917 strout ("#<buffer ", -1, -1, printcharfun
, 0);
1918 print_string (XBUFFER (obj
)->name
, printcharfun
);
1922 print_string (XBUFFER (obj
)->name
, printcharfun
);
1924 else if (WINDOW_CONFIGURATIONP (obj
))
1926 strout ("#<window-configuration>", -1, -1, printcharfun
, 0);
1928 else if (FRAMEP (obj
))
1930 strout ((FRAME_LIVE_P (XFRAME (obj
))
1931 ? "#<frame " : "#<dead frame "),
1932 -1, -1, printcharfun
, 0);
1933 print_string (XFRAME (obj
)->name
, printcharfun
);
1934 sprintf (buf
, " 0x%lx", (unsigned long) (XFRAME (obj
)));
1935 strout (buf
, -1, -1, printcharfun
, 0);
1940 EMACS_INT size
= XVECTOR (obj
)->size
;
1941 if (COMPILEDP (obj
))
1944 size
&= PSEUDOVECTOR_SIZE_MASK
;
1946 if (CHAR_TABLE_P (obj
))
1948 /* We print a char-table as if it were a vector,
1949 lumping the parent and default slots in with the
1950 character slots. But we add #^ as a prefix. */
1953 if (SUB_CHAR_TABLE_P (obj
))
1955 size
&= PSEUDOVECTOR_SIZE_MASK
;
1957 if (size
& PSEUDOVECTOR_FLAG
)
1963 register Lisp_Object tem
;
1964 int real_size
= size
;
1966 /* Don't print more elements than the specified maximum. */
1967 if (NATNUMP (Vprint_length
)
1968 && XFASTINT (Vprint_length
) < size
)
1969 size
= XFASTINT (Vprint_length
);
1971 for (i
= 0; i
< size
; i
++)
1973 if (i
) PRINTCHAR (' ');
1974 tem
= XVECTOR (obj
)->contents
[i
];
1975 print_object (tem
, printcharfun
, escapeflag
);
1977 if (size
< real_size
)
1978 strout (" ...", 4, 4, printcharfun
, 0);
1985 switch (XMISCTYPE (obj
))
1987 case Lisp_Misc_Marker
:
1988 strout ("#<marker ", -1, -1, printcharfun
, 0);
1989 /* Do you think this is necessary? */
1990 if (XMARKER (obj
)->insertion_type
!= 0)
1991 strout ("(moves after insertion) ", -1, -1, printcharfun
, 0);
1992 if (!(XMARKER (obj
)->buffer
))
1993 strout ("in no buffer", -1, -1, printcharfun
, 0);
1996 sprintf (buf
, "at %d", marker_position (obj
));
1997 strout (buf
, -1, -1, printcharfun
, 0);
1998 strout (" in ", -1, -1, printcharfun
, 0);
1999 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
2004 case Lisp_Misc_Overlay
:
2005 strout ("#<overlay ", -1, -1, printcharfun
, 0);
2006 if (!(XMARKER (OVERLAY_START (obj
))->buffer
))
2007 strout ("in no buffer", -1, -1, printcharfun
, 0);
2010 sprintf (buf
, "from %d to %d in ",
2011 marker_position (OVERLAY_START (obj
)),
2012 marker_position (OVERLAY_END (obj
)));
2013 strout (buf
, -1, -1, printcharfun
, 0);
2014 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
2020 /* Remaining cases shouldn't happen in normal usage, but let's print
2021 them anyway for the benefit of the debugger. */
2022 case Lisp_Misc_Free
:
2023 strout ("#<misc free cell>", -1, -1, printcharfun
, 0);
2026 case Lisp_Misc_Intfwd
:
2027 sprintf (buf
, "#<intfwd to %ld>", (long) *XINTFWD (obj
)->intvar
);
2028 strout (buf
, -1, -1, printcharfun
, 0);
2031 case Lisp_Misc_Boolfwd
:
2032 sprintf (buf
, "#<boolfwd to %s>",
2033 (*XBOOLFWD (obj
)->boolvar
? "t" : "nil"));
2034 strout (buf
, -1, -1, printcharfun
, 0);
2037 case Lisp_Misc_Objfwd
:
2038 strout ("#<objfwd to ", -1, -1, printcharfun
, 0);
2039 print_object (*XOBJFWD (obj
)->objvar
, printcharfun
, escapeflag
);
2043 case Lisp_Misc_Buffer_Objfwd
:
2044 strout ("#<buffer_objfwd to ", -1, -1, printcharfun
, 0);
2045 print_object (PER_BUFFER_VALUE (current_buffer
,
2046 XBUFFER_OBJFWD (obj
)->offset
),
2047 printcharfun
, escapeflag
);
2051 case Lisp_Misc_Kboard_Objfwd
:
2052 strout ("#<kboard_objfwd to ", -1, -1, printcharfun
, 0);
2053 print_object (*(Lisp_Object
*)((char *) current_kboard
2054 + XKBOARD_OBJFWD (obj
)->offset
),
2055 printcharfun
, escapeflag
);
2059 case Lisp_Misc_Buffer_Local_Value
:
2060 strout ("#<buffer_local_value ", -1, -1, printcharfun
, 0);
2061 goto do_buffer_local
;
2062 case Lisp_Misc_Some_Buffer_Local_Value
:
2063 strout ("#<some_buffer_local_value ", -1, -1, printcharfun
, 0);
2065 strout ("[realvalue] ", -1, -1, printcharfun
, 0);
2066 print_object (XBUFFER_LOCAL_VALUE (obj
)->realvalue
,
2067 printcharfun
, escapeflag
);
2068 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_buffer
)
2069 strout ("[local in buffer] ", -1, -1, printcharfun
, 0);
2071 strout ("[buffer] ", -1, -1, printcharfun
, 0);
2072 print_object (XBUFFER_LOCAL_VALUE (obj
)->buffer
,
2073 printcharfun
, escapeflag
);
2074 if (XBUFFER_LOCAL_VALUE (obj
)->check_frame
)
2076 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_frame
)
2077 strout ("[local in frame] ", -1, -1, printcharfun
, 0);
2079 strout ("[frame] ", -1, -1, printcharfun
, 0);
2080 print_object (XBUFFER_LOCAL_VALUE (obj
)->frame
,
2081 printcharfun
, escapeflag
);
2083 strout ("[alist-elt] ", -1, -1, printcharfun
, 0);
2084 print_object (XCAR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
2085 printcharfun
, escapeflag
);
2086 strout ("[default-value] ", -1, -1, printcharfun
, 0);
2087 print_object (XCDR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
2088 printcharfun
, escapeflag
);
2092 case Lisp_Misc_Save_Value
:
2093 strout ("#<save_value ", -1, -1, printcharfun
, 0);
2094 sprintf(buf
, "ptr=0x%08lx int=%d",
2095 (unsigned long) XSAVE_VALUE (obj
)->pointer
,
2096 XSAVE_VALUE (obj
)->integer
);
2097 strout (buf
, -1, -1, printcharfun
, 0);
2109 /* We're in trouble if this happens!
2110 Probably should just abort () */
2111 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
, 0);
2113 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2114 else if (VECTORLIKEP (obj
))
2115 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
2117 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2118 strout (buf
, -1, -1, printcharfun
, 0);
2119 strout (" Save your buffers immediately and please report this bug>",
2120 -1, -1, printcharfun
, 0);
2128 /* Print a description of INTERVAL using PRINTCHARFUN.
2129 This is part of printing a string that has text properties. */
2132 print_interval (interval
, printcharfun
)
2134 Lisp_Object printcharfun
;
2137 print_object (make_number (interval
->position
), printcharfun
, 1);
2139 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2142 print_object (interval
->plist
, printcharfun
, 1);
2149 Qtemp_buffer_setup_hook
= intern ("temp-buffer-setup-hook");
2150 staticpro (&Qtemp_buffer_setup_hook
);
2152 DEFVAR_LISP ("standard-output", &Vstandard_output
,
2153 doc
: /* Output stream `print' uses by default for outputting a character.
2154 This may be any function of one argument.
2155 It may also be a buffer (output is inserted before point)
2156 or a marker (output is inserted and the marker is advanced)
2157 or the symbol t (output appears in the echo area). */);
2158 Vstandard_output
= Qt
;
2159 Qstandard_output
= intern ("standard-output");
2160 staticpro (&Qstandard_output
);
2162 DEFVAR_LISP ("float-output-format", &Vfloat_output_format
,
2163 doc
: /* The format descriptor string used to print floats.
2164 This is a %-spec like those accepted by `printf' in C,
2165 but with some restrictions. It must start with the two characters `%.'.
2166 After that comes an integer precision specification,
2167 and then a letter which controls the format.
2168 The letters allowed are `e', `f' and `g'.
2169 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2170 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2171 Use `g' to choose the shorter of those two formats for the number at hand.
2172 The precision in any of these cases is the number of digits following
2173 the decimal point. With `f', a precision of 0 means to omit the
2174 decimal point. 0 is not allowed with `e' or `g'.
2176 A value of nil means to use the shortest notation
2177 that represents the number without losing information. */);
2178 Vfloat_output_format
= Qnil
;
2179 Qfloat_output_format
= intern ("float-output-format");
2180 staticpro (&Qfloat_output_format
);
2182 DEFVAR_LISP ("print-length", &Vprint_length
,
2183 doc
: /* Maximum length of list to print before abbreviating.
2184 A value of nil means no limit. See also `eval-expression-print-length'. */);
2185 Vprint_length
= Qnil
;
2187 DEFVAR_LISP ("print-level", &Vprint_level
,
2188 doc
: /* Maximum depth of list nesting to print before abbreviating.
2189 A value of nil means no limit. See also `eval-expression-print-level'. */);
2190 Vprint_level
= Qnil
;
2192 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines
,
2193 doc
: /* Non-nil means print newlines in strings as `\\n'.
2194 Also print formfeeds as `\\f'. */);
2195 print_escape_newlines
= 0;
2197 DEFVAR_BOOL ("print-escape-nonascii", &print_escape_nonascii
,
2198 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2199 \(OOO is the octal representation of the character code.)
2200 Only single-byte characters are affected, and only in `prin1'.
2201 When the output goes in a multibyte buffer, this feature is
2202 enabled regardless of the value of the variable. */);
2203 print_escape_nonascii
= 0;
2205 DEFVAR_BOOL ("print-escape-multibyte", &print_escape_multibyte
,
2206 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2207 \(XXXX is the hex representation of the character code.)
2208 This affects only `prin1'. */);
2209 print_escape_multibyte
= 0;
2211 DEFVAR_BOOL ("print-quoted", &print_quoted
,
2212 doc
: /* Non-nil means print quoted forms with reader syntax.
2213 I.e., (quote foo) prints as 'foo, (function foo) as #'foo, and backquoted
2214 forms print as in the new syntax. */);
2217 DEFVAR_LISP ("print-gensym", &Vprint_gensym
,
2218 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2219 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2220 When the uninterned symbol appears within a recursive data structure,
2221 and the symbol appears more than once, in addition use the #N# and #N=
2222 constructs as needed, so that multiple references to the same symbol are
2223 shared once again when the text is read back. */);
2224 Vprint_gensym
= Qnil
;
2226 DEFVAR_LISP ("print-circle", &Vprint_circle
,
2227 doc
: /* *Non-nil means print recursive structures using #N= and #N# syntax.
2228 If nil, printing proceeds recursively and may lead to
2229 `max-lisp-eval-depth' being exceeded or an error may occur:
2230 \"Apparently circular structure being printed.\" Also see
2231 `print-length' and `print-level'.
2232 If non-nil, shared substructures anywhere in the structure are printed
2233 with `#N=' before the first occurrence (in the order of the print
2234 representation) and `#N#' in place of each subsequent occurrence,
2235 where N is a positive decimal integer. */);
2236 Vprint_circle
= Qnil
;
2238 DEFVAR_LISP ("print-continuous-numbering", &Vprint_continuous_numbering
,
2239 doc
: /* *Non-nil means number continuously across print calls.
2240 This affects the numbers printed for #N= labels and #M# references.
2241 See also `print-circle', `print-gensym', and `print-number-table'.
2242 This variable should not be set with `setq'; bind it with a `let' instead. */);
2243 Vprint_continuous_numbering
= Qnil
;
2245 DEFVAR_LISP ("print-number-table", &Vprint_number_table
,
2246 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2247 The Lisp printer uses this vector to detect Lisp objects referenced more
2250 When you bind `print-continuous-numbering' to t, you should probably
2251 also bind `print-number-table' to nil. This ensures that the value of
2252 `print-number-table' can be garbage-collected once the printing is
2253 done. If all elements of `print-number-table' are nil, it means that
2254 the printing done so far has not found any shared structure or objects
2255 that need to be recorded in the table. */);
2256 Vprint_number_table
= Qnil
;
2258 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2259 staticpro (&Vprin1_to_string_buffer
);
2262 defsubr (&Sprin1_to_string
);
2263 defsubr (&Serror_message_string
);
2267 defsubr (&Swrite_char
);
2268 defsubr (&Sexternal_debugging_output
);
2269 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2270 defsubr (&Sredirect_debugging_output
);
2273 Qexternal_debugging_output
= intern ("external-debugging-output");
2274 staticpro (&Qexternal_debugging_output
);
2276 Qprint_escape_newlines
= intern ("print-escape-newlines");
2277 staticpro (&Qprint_escape_newlines
);
2279 Qprint_escape_multibyte
= intern ("print-escape-multibyte");
2280 staticpro (&Qprint_escape_multibyte
);
2282 Qprint_escape_nonascii
= intern ("print-escape-nonascii");
2283 staticpro (&Qprint_escape_nonascii
);
2285 defsubr (&Swith_output_to_temp_buffer
);
2288 /* arch-tag: bc797170-94ae-41de-86e3-75e20f8f7a39
2289 (do not change this comment) */