1 /* Lisp object printing and output streams.
2 Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000, 01, 03, 2004
3 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., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
27 #include "character.h"
33 #include "dispextern.h"
35 #include "intervals.h"
37 Lisp_Object Vstandard_output
, Qstandard_output
;
39 Lisp_Object Qtemp_buffer_setup_hook
;
41 /* These are used to print like we read. */
42 extern Lisp_Object Qbackquote
, Qcomma
, Qcomma_at
, Qcomma_dot
, Qfunction
;
44 Lisp_Object Vfloat_output_format
, Qfloat_output_format
;
46 /* Work around a problem that happens because math.h on hpux 7
47 defines two static variables--which, in Emacs, are not really static,
48 because `static' is defined as nothing. The problem is that they are
49 defined both here and in lread.c.
50 These macros prevent the name conflict. */
51 #if defined (HPUX) && !defined (HPUX8)
52 #define _MAXLDBL print_maxldbl
53 #define _NMAXLDBL print_nmaxldbl
62 /* Default to values appropriate for IEEE floating point. */
67 #define DBL_MANT_DIG 53
73 #define DBL_MIN 2.2250738585072014e-308
76 #ifdef DBL_MIN_REPLACEMENT
78 #define DBL_MIN DBL_MIN_REPLACEMENT
81 /* Define DOUBLE_DIGITS_BOUND, an upper bound on the number of decimal digits
82 needed to express a float without losing information.
83 The general-case formula is valid for the usual case, IEEE floating point,
84 but many compilers can't optimize the formula to an integer constant,
85 so make a special case for it. */
86 #if FLT_RADIX == 2 && DBL_MANT_DIG == 53
87 #define DOUBLE_DIGITS_BOUND 17 /* IEEE floating point */
89 #define DOUBLE_DIGITS_BOUND ((int) ceil (log10 (pow (FLT_RADIX, DBL_MANT_DIG))))
92 /* Avoid actual stack overflow in print. */
95 /* Nonzero if inside outputting backquote in old style. */
96 int old_backquote_output
;
98 /* Detect most circularities to print finite output. */
99 #define PRINT_CIRCLE 200
100 Lisp_Object being_printed
[PRINT_CIRCLE
];
102 /* When printing into a buffer, first we put the text in this
103 block, then insert it all at once. */
106 /* Size allocated in print_buffer. */
107 int print_buffer_size
;
108 /* Chars stored in print_buffer. */
109 int print_buffer_pos
;
110 /* Bytes stored in print_buffer. */
111 int print_buffer_pos_byte
;
113 /* Maximum length of list to print in full; noninteger means
114 effectively infinity */
116 Lisp_Object Vprint_length
;
118 /* Maximum depth of list to print in full; noninteger means
119 effectively infinity. */
121 Lisp_Object Vprint_level
;
123 /* Nonzero means print newlines in strings as \n. */
125 int print_escape_newlines
;
127 /* Nonzero means to print single-byte non-ascii characters in strings as
130 int print_escape_nonascii
;
132 /* Nonzero means to print multibyte characters in strings as hex escapes. */
134 int print_escape_multibyte
;
136 Lisp_Object Qprint_escape_newlines
;
137 Lisp_Object Qprint_escape_multibyte
, Qprint_escape_nonascii
;
139 /* Nonzero means print (quote foo) forms as 'foo, etc. */
143 /* Non-nil means print #: before uninterned symbols. */
145 Lisp_Object Vprint_gensym
;
147 /* Non-nil means print recursive structures using #n= and #n# syntax. */
149 Lisp_Object Vprint_circle
;
151 /* Non-nil means keep continuous number for #n= and #n# syntax
152 between several print functions. */
154 Lisp_Object Vprint_continuous_numbering
;
156 /* Vprint_number_table is a vector like [OBJ1 STAT1 OBJ2 STAT2 ...],
157 where OBJn are objects going to be printed, and STATn are their status,
158 which may be different meanings during process. See the comments of
159 the functions print and print_preprocess for details.
160 print_number_index keeps the last position the next object should be added,
161 twice of which is the actual vector position in Vprint_number_table. */
162 int print_number_index
;
163 Lisp_Object Vprint_number_table
;
165 /* PRINT_NUMBER_OBJECT returns the I'th object in Vprint_number_table TABLE.
166 PRINT_NUMBER_STATUS returns the status of the I'th object in TABLE.
167 See the comment of the variable Vprint_number_table. */
168 #define PRINT_NUMBER_OBJECT(table,i) XVECTOR ((table))->contents[(i) * 2]
169 #define PRINT_NUMBER_STATUS(table,i) XVECTOR ((table))->contents[(i) * 2 + 1]
171 /* Nonzero means print newline to stdout before next minibuffer message.
172 Defined in xdisp.c */
174 extern int noninteractive_need_newline
;
176 extern int minibuffer_auto_raise
;
178 #ifdef MAX_PRINT_CHARS
179 static int print_chars
;
180 static int max_print
;
181 #endif /* MAX_PRINT_CHARS */
183 void print_interval ();
186 /* Low level output routines for characters and strings */
188 /* Lisp functions to do output using a stream
189 must have the stream in a variable called printcharfun
190 and must start with PRINTPREPARE, end with PRINTFINISH,
191 and use PRINTDECLARE to declare common variables.
192 Use PRINTCHAR to output one character,
193 or call strout to output a block of characters. */
195 #define PRINTDECLARE \
196 struct buffer *old = current_buffer; \
197 int old_point = -1, start_point = -1; \
198 int old_point_byte = -1, start_point_byte = -1; \
199 int specpdl_count = SPECPDL_INDEX (); \
200 int free_print_buffer = 0; \
201 int multibyte = !NILP (current_buffer->enable_multibyte_characters); \
204 #define PRINTPREPARE \
205 original = printcharfun; \
206 if (NILP (printcharfun)) printcharfun = Qt; \
207 if (BUFFERP (printcharfun)) \
209 if (XBUFFER (printcharfun) != current_buffer) \
210 Fset_buffer (printcharfun); \
211 printcharfun = Qnil; \
213 if (MARKERP (printcharfun)) \
215 if (!(XMARKER (original)->buffer)) \
216 error ("Marker does not point anywhere"); \
217 if (XMARKER (original)->buffer != current_buffer) \
218 set_buffer_internal (XMARKER (original)->buffer); \
220 old_point_byte = PT_BYTE; \
221 SET_PT_BOTH (marker_position (printcharfun), \
222 marker_byte_position (printcharfun)); \
224 start_point_byte = PT_BYTE; \
225 printcharfun = Qnil; \
227 if (NILP (printcharfun)) \
229 Lisp_Object string; \
230 if (NILP (current_buffer->enable_multibyte_characters) \
231 && ! print_escape_multibyte) \
232 specbind (Qprint_escape_multibyte, Qt); \
233 if (! NILP (current_buffer->enable_multibyte_characters) \
234 && ! print_escape_nonascii) \
235 specbind (Qprint_escape_nonascii, Qt); \
236 if (print_buffer != 0) \
238 string = make_string_from_bytes (print_buffer, \
240 print_buffer_pos_byte); \
241 record_unwind_protect (print_unwind, string); \
245 print_buffer_size = 1000; \
246 print_buffer = (char *) xmalloc (print_buffer_size); \
247 free_print_buffer = 1; \
249 print_buffer_pos = 0; \
250 print_buffer_pos_byte = 0; \
252 if (EQ (printcharfun, Qt) && ! noninteractive) \
253 setup_echo_area_for_printing (multibyte);
255 #define PRINTFINISH \
256 if (NILP (printcharfun)) \
258 if (print_buffer_pos != print_buffer_pos_byte \
259 && NILP (current_buffer->enable_multibyte_characters)) \
261 unsigned char *temp \
262 = (unsigned char *) alloca (print_buffer_pos + 1); \
263 copy_text (print_buffer, temp, print_buffer_pos_byte, \
265 insert_1_both (temp, print_buffer_pos, \
266 print_buffer_pos, 0, 1, 0); \
269 insert_1_both (print_buffer, print_buffer_pos, \
270 print_buffer_pos_byte, 0, 1, 0); \
272 if (free_print_buffer) \
274 xfree (print_buffer); \
277 unbind_to (specpdl_count, Qnil); \
278 if (MARKERP (original)) \
279 set_marker_both (original, Qnil, PT, PT_BYTE); \
280 if (old_point >= 0) \
281 SET_PT_BOTH (old_point + (old_point >= start_point \
282 ? PT - start_point : 0), \
283 old_point_byte + (old_point_byte >= start_point_byte \
284 ? PT_BYTE - start_point_byte : 0)); \
285 if (old != current_buffer) \
286 set_buffer_internal (old);
288 #define PRINTCHAR(ch) printchar (ch, printcharfun)
290 /* This is used to restore the saved contents of print_buffer
291 when there is a recursive call to print. */
294 print_unwind (saved_text
)
295 Lisp_Object saved_text
;
297 bcopy (SDATA (saved_text
), print_buffer
, SCHARS (saved_text
));
302 /* Print character CH using method FUN. FUN nil means print to
303 print_buffer. FUN t means print to echo area or stdout if
304 non-interactive. If FUN is neither nil nor t, call FUN with CH as
312 #ifdef MAX_PRINT_CHARS
315 #endif /* MAX_PRINT_CHARS */
317 if (!NILP (fun
) && !EQ (fun
, Qt
))
318 call1 (fun
, make_number (ch
));
321 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
322 int len
= CHAR_STRING (ch
, str
);
328 if (print_buffer_pos_byte
+ len
>= print_buffer_size
)
329 print_buffer
= (char *) xrealloc (print_buffer
,
330 print_buffer_size
*= 2);
331 bcopy (str
, print_buffer
+ print_buffer_pos_byte
, len
);
332 print_buffer_pos
+= 1;
333 print_buffer_pos_byte
+= len
;
335 else if (noninteractive
)
337 fwrite (str
, 1, len
, stdout
);
338 noninteractive_need_newline
= 1;
343 = !NILP (current_buffer
->enable_multibyte_characters
);
345 setup_echo_area_for_printing (multibyte_p
);
347 message_dolog (str
, len
, 0, multibyte_p
);
353 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
354 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
355 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
356 print_buffer. PRINTCHARFUN t means output to the echo area or to
357 stdout if non-interactive. If neither nil nor t, call Lisp
358 function PRINTCHARFUN for each character printed. MULTIBYTE
359 non-zero means PTR contains multibyte characters. */
362 strout (ptr
, size
, size_byte
, printcharfun
, multibyte
)
365 Lisp_Object printcharfun
;
369 size_byte
= size
= strlen (ptr
);
371 if (NILP (printcharfun
))
373 if (print_buffer_pos_byte
+ size_byte
> print_buffer_size
)
375 print_buffer_size
= print_buffer_size
* 2 + size_byte
;
376 print_buffer
= (char *) xrealloc (print_buffer
,
379 bcopy (ptr
, print_buffer
+ print_buffer_pos_byte
, size_byte
);
380 print_buffer_pos
+= size
;
381 print_buffer_pos_byte
+= size_byte
;
383 #ifdef MAX_PRINT_CHARS
386 #endif /* MAX_PRINT_CHARS */
388 else if (noninteractive
&& EQ (printcharfun
, Qt
))
390 fwrite (ptr
, 1, size_byte
, stdout
);
391 noninteractive_need_newline
= 1;
393 else if (EQ (printcharfun
, Qt
))
395 /* Output to echo area. We're trying to avoid a little overhead
396 here, that's the reason we don't call printchar to do the
400 = !NILP (current_buffer
->enable_multibyte_characters
);
402 setup_echo_area_for_printing (multibyte_p
);
403 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
405 if (size
== size_byte
)
407 for (i
= 0; i
< size
; ++i
)
408 insert_char ((unsigned char )*ptr
++);
413 for (i
= 0; i
< size_byte
; i
+= len
)
415 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size_byte
- i
, len
);
420 #ifdef MAX_PRINT_CHARS
423 #endif /* MAX_PRINT_CHARS */
427 /* PRINTCHARFUN is a Lisp function. */
430 if (size
== size_byte
)
432 while (i
< size_byte
)
440 while (i
< size_byte
)
442 /* Here, we must convert each multi-byte form to the
443 corresponding character code before handing it to
446 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size_byte
- i
, len
);
454 /* Print the contents of a string STRING using PRINTCHARFUN.
455 It isn't safe to use strout in many cases,
456 because printing one char can relocate. */
459 print_string (string
, printcharfun
)
461 Lisp_Object printcharfun
;
463 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
467 if (print_escape_nonascii
)
468 string
= string_escape_byte8 (string
);
470 if (STRING_MULTIBYTE (string
))
471 chars
= SCHARS (string
);
472 else if (! print_escape_nonascii
473 && (EQ (printcharfun
, Qt
)
474 ? ! NILP (buffer_defaults
.enable_multibyte_characters
)
475 : ! NILP (current_buffer
->enable_multibyte_characters
)))
477 /* If unibyte string STRING contains 8-bit codes, we must
478 convert STRING to a multibyte string containing the same
483 chars
= SBYTES (string
);
484 bytes
= parse_str_to_multibyte (SDATA (string
), chars
);
487 newstr
= make_uninit_multibyte_string (chars
, bytes
);
488 bcopy (SDATA (string
), SDATA (newstr
), chars
);
489 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
494 chars
= SBYTES (string
);
496 /* strout is safe for output to a frame (echo area) or to print_buffer. */
497 strout (SDATA (string
),
498 chars
, SBYTES (string
),
499 printcharfun
, STRING_MULTIBYTE (string
));
503 /* Otherwise, string may be relocated by printing one char.
504 So re-fetch the string address for each character. */
506 int size
= SCHARS (string
);
507 int size_byte
= SBYTES (string
);
510 if (size
== size_byte
)
511 for (i
= 0; i
< size
; i
++)
512 PRINTCHAR (SREF (string
, i
));
514 for (i
= 0; i
< size_byte
; )
516 /* Here, we must convert each multi-byte form to the
517 corresponding character code before handing it to PRINTCHAR. */
519 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
,
528 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
529 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
530 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
531 (character
, printcharfun
)
532 Lisp_Object character
, printcharfun
;
536 if (NILP (printcharfun
))
537 printcharfun
= Vstandard_output
;
538 CHECK_NUMBER (character
);
540 PRINTCHAR (XINT (character
));
545 /* Used from outside of print.c to print a block of SIZE
546 single-byte chars at DATA on the default output stream.
547 Do not use this on the contents of a Lisp string. */
550 write_string (data
, size
)
555 Lisp_Object printcharfun
;
557 printcharfun
= Vstandard_output
;
560 strout (data
, size
, size
, printcharfun
, 0);
564 /* Used from outside of print.c to print a block of SIZE
565 single-byte chars at DATA on a specified stream PRINTCHARFUN.
566 Do not use this on the contents of a Lisp string. */
569 write_string_1 (data
, size
, printcharfun
)
572 Lisp_Object printcharfun
;
577 strout (data
, size
, size
, printcharfun
, 0);
583 temp_output_buffer_setup (bufname
)
586 int count
= SPECPDL_INDEX ();
587 register struct buffer
*old
= current_buffer
;
588 register Lisp_Object buf
;
590 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
592 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
594 Fkill_all_local_variables ();
595 delete_all_overlays (current_buffer
);
596 current_buffer
->directory
= old
->directory
;
597 current_buffer
->read_only
= Qnil
;
598 current_buffer
->filename
= Qnil
;
599 current_buffer
->undo_list
= Qt
;
600 eassert (current_buffer
->overlays_before
== NULL
);
601 eassert (current_buffer
->overlays_after
== NULL
);
602 current_buffer
->enable_multibyte_characters
603 = buffer_defaults
.enable_multibyte_characters
;
604 specbind (Qinhibit_read_only
, Qt
);
605 specbind (Qinhibit_modification_hooks
, Qt
);
607 XSETBUFFER (buf
, current_buffer
);
609 Frun_hooks (1, &Qtemp_buffer_setup_hook
);
611 unbind_to (count
, Qnil
);
613 specbind (Qstandard_output
, buf
);
617 internal_with_output_to_temp_buffer (bufname
, function
, args
)
619 Lisp_Object (*function
) P_ ((Lisp_Object
));
622 int count
= SPECPDL_INDEX ();
623 Lisp_Object buf
, val
;
627 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
628 temp_output_buffer_setup (bufname
);
629 buf
= Vstandard_output
;
632 val
= (*function
) (args
);
635 temp_output_buffer_show (buf
);
638 return unbind_to (count
, val
);
641 DEFUN ("with-output-to-temp-buffer",
642 Fwith_output_to_temp_buffer
, Swith_output_to_temp_buffer
,
644 doc
: /* Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
645 The buffer is cleared out initially, and marked as unmodified when done.
646 All output done by BODY is inserted in that buffer by default.
647 The buffer is displayed in another window, but not selected.
648 The value of the last form in BODY is returned.
649 If BODY does not finish normally, the buffer BUFNAME is not displayed.
651 The hook `temp-buffer-setup-hook' is run before BODY,
652 with the buffer BUFNAME temporarily current.
653 The hook `temp-buffer-show-hook' is run after the buffer is displayed,
654 with the buffer temporarily current, and the window that was used
655 to display it temporarily selected.
657 If variable `temp-buffer-show-function' is non-nil, call it at the end
658 to get the buffer displayed instead of just displaying the non-selected
659 buffer and calling the hook. It gets one argument, the buffer to display.
661 usage: (with-output-to-temp-buffer BUFNAME BODY ...) */)
667 int count
= SPECPDL_INDEX ();
668 Lisp_Object buf
, val
;
671 name
= Feval (Fcar (args
));
673 temp_output_buffer_setup (SDATA (name
));
674 buf
= Vstandard_output
;
677 val
= Fprogn (XCDR (args
));
680 temp_output_buffer_show (buf
);
683 return unbind_to (count
, val
);
687 static void print ();
688 static void print_preprocess ();
689 static void print_preprocess_string ();
690 static void print_object ();
692 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
693 doc
: /* Output a newline to stream PRINTCHARFUN.
694 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
696 Lisp_Object printcharfun
;
700 if (NILP (printcharfun
))
701 printcharfun
= Vstandard_output
;
708 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
709 doc
: /* Output the printed representation of OBJECT, any Lisp object.
710 Quoting characters are printed when needed to make output that `read'
711 can handle, whenever this is possible. For complex objects, the behavior
712 is controlled by `print-level' and `print-length', which see.
714 OBJECT is any of the Lisp data types: a number, a string, a symbol,
715 a list, a buffer, a window, a frame, etc.
717 A printed representation of an object is text which describes that object.
719 Optional argument PRINTCHARFUN is the output stream, which can be one
722 - a buffer, in which case output is inserted into that buffer at point;
723 - a marker, in which case output is inserted at marker's position;
724 - a function, in which case that function is called once for each
725 character of OBJECT's printed representation;
726 - a symbol, in which case that symbol's function definition is called; or
727 - t, in which case the output is displayed in the echo area.
729 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
731 (object
, printcharfun
)
732 Lisp_Object object
, printcharfun
;
736 #ifdef MAX_PRINT_CHARS
738 #endif /* MAX_PRINT_CHARS */
739 if (NILP (printcharfun
))
740 printcharfun
= Vstandard_output
;
742 print (object
, printcharfun
, 1);
747 /* a buffer which is used to hold output being built by prin1-to-string */
748 Lisp_Object Vprin1_to_string_buffer
;
750 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
751 doc
: /* Return a string containing the printed representation of OBJECT.
752 OBJECT can be any Lisp object. This function outputs quoting characters
753 when necessary to make output that `read' can handle, whenever possible,
754 unless the optional second argument NOESCAPE is non-nil.
756 OBJECT is any of the Lisp data types: a number, a string, a symbol,
757 a list, a buffer, a window, a frame, etc.
759 A printed representation of an object is text which describes that object. */)
761 Lisp_Object object
, noescape
;
763 Lisp_Object printcharfun
;
764 /* struct gcpro gcpro1, gcpro2; */
765 Lisp_Object save_deactivate_mark
;
766 int count
= specpdl_ptr
- specpdl
;
767 struct buffer
*previous
;
769 specbind (Qinhibit_modification_hooks
, Qt
);
774 /* Save and restore this--we are altering a buffer
775 but we don't want to deactivate the mark just for that.
776 No need for specbind, since errors deactivate the mark. */
777 save_deactivate_mark
= Vdeactivate_mark
;
778 /* GCPRO2 (object, save_deactivate_mark); */
781 printcharfun
= Vprin1_to_string_buffer
;
783 print (object
, printcharfun
, NILP (noescape
));
784 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
788 previous
= current_buffer
;
789 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
790 object
= Fbuffer_string ();
791 if (SBYTES (object
) == SCHARS (object
))
792 STRING_SET_UNIBYTE (object
);
794 /* Note that this won't make prepare_to_modify_buffer call
795 ask-user-about-supersession-threat because this buffer
796 does not visit a file. */
798 set_buffer_internal (previous
);
800 Vdeactivate_mark
= save_deactivate_mark
;
804 return unbind_to (count
, object
);
807 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
808 doc
: /* Output the printed representation of OBJECT, any Lisp object.
809 No quoting characters are used; no delimiters are printed around
810 the contents of strings.
812 OBJECT is any of the Lisp data types: a number, a string, a symbol,
813 a list, a buffer, a window, a frame, etc.
815 A printed representation of an object is text which describes that object.
817 Optional argument PRINTCHARFUN is the output stream, which can be one
820 - a buffer, in which case output is inserted into that buffer at point;
821 - a marker, in which case output is inserted at marker's position;
822 - a function, in which case that function is called once for each
823 character of OBJECT's printed representation;
824 - a symbol, in which case that symbol's function definition is called; or
825 - t, in which case the output is displayed in the echo area.
827 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
829 (object
, printcharfun
)
830 Lisp_Object object
, printcharfun
;
834 if (NILP (printcharfun
))
835 printcharfun
= Vstandard_output
;
837 print (object
, printcharfun
, 0);
842 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
843 doc
: /* Output the printed representation of OBJECT, with newlines around it.
844 Quoting characters are printed when needed to make output that `read'
845 can handle, whenever this is possible. For complex objects, the behavior
846 is controlled by `print-level' and `print-length', which see.
848 OBJECT is any of the Lisp data types: a number, a string, a symbol,
849 a list, a buffer, a window, a frame, etc.
851 A printed representation of an object is text which describes that object.
853 Optional argument PRINTCHARFUN is the output stream, which can be one
856 - a buffer, in which case output is inserted into that buffer at point;
857 - a marker, in which case output is inserted at marker's position;
858 - a function, in which case that function is called once for each
859 character of OBJECT's printed representation;
860 - a symbol, in which case that symbol's function definition is called; or
861 - t, in which case the output is displayed in the echo area.
863 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
865 (object
, printcharfun
)
866 Lisp_Object object
, printcharfun
;
871 #ifdef MAX_PRINT_CHARS
873 max_print
= MAX_PRINT_CHARS
;
874 #endif /* MAX_PRINT_CHARS */
875 if (NILP (printcharfun
))
876 printcharfun
= Vstandard_output
;
880 print (object
, printcharfun
, 1);
883 #ifdef MAX_PRINT_CHARS
886 #endif /* MAX_PRINT_CHARS */
891 /* The subroutine object for external-debugging-output is kept here
892 for the convenience of the debugger. */
893 Lisp_Object Qexternal_debugging_output
;
895 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
896 doc
: /* Write CHARACTER to stderr.
897 You can call print while debugging emacs, and pass it this function
898 to make it write to the debugging output. */)
900 Lisp_Object character
;
902 CHECK_NUMBER (character
);
903 putc (XINT (character
), stderr
);
906 /* Send the output to a debugger (nothing happens if there isn't one). */
908 char buf
[2] = {(char) XINT (character
), '\0'};
909 OutputDebugString (buf
);
917 #if defined(GNU_LINUX)
919 /* This functionality is not vitally important in general, so we rely on
920 non-portable ability to use stderr as lvalue. */
922 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
924 FILE *initial_stderr_stream
= NULL
;
926 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
928 "FDebug output file: \nP",
929 doc
: /* Redirect debugging output (stderr stream) to file FILE.
930 If FILE is nil, reset target to the initial stderr stream.
931 Optional arg APPEND non-nil (interactively, with prefix arg) means
932 append to existing target file. */)
934 Lisp_Object file
, append
;
936 if (initial_stderr_stream
!= NULL
)
938 stderr
= initial_stderr_stream
;
939 initial_stderr_stream
= NULL
;
943 file
= Fexpand_file_name (file
, Qnil
);
944 initial_stderr_stream
= stderr
;
945 stderr
= fopen(SDATA (file
), NILP (append
) ? "w" : "a");
948 stderr
= initial_stderr_stream
;
949 initial_stderr_stream
= NULL
;
950 report_file_error ("Cannot open debugging output stream",
956 #endif /* GNU_LINUX */
959 /* This is the interface for debugging printing. */
965 Fprin1 (arg
, Qexternal_debugging_output
);
966 fprintf (stderr
, "\r\n");
969 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
971 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
972 See Info anchor `(elisp)Definition of signal' for some details on how this
973 error message is constructed. */)
977 struct buffer
*old
= current_buffer
;
981 /* If OBJ is (error STRING), just return STRING.
982 That is not only faster, it also avoids the need to allocate
983 space here when the error is due to memory full. */
984 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
985 && CONSP (XCDR (obj
))
986 && STRINGP (XCAR (XCDR (obj
)))
987 && NILP (XCDR (XCDR (obj
))))
988 return XCAR (XCDR (obj
));
990 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
992 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
993 value
= Fbuffer_string ();
997 set_buffer_internal (old
);
1003 /* Print an error message for the error DATA onto Lisp output stream
1004 STREAM (suitable for the print functions). */
1007 print_error_message (data
, stream
, context
, caller
)
1008 Lisp_Object data
, stream
;
1012 Lisp_Object errname
, errmsg
, file_error
, tail
;
1013 struct gcpro gcpro1
;
1017 write_string_1 (context
, -1, stream
);
1019 /* If we know from where the error was signaled, show it in
1021 if (!NILP (caller
) && SYMBOLP (caller
))
1023 const char *name
= SDATA (SYMBOL_NAME (caller
));
1024 message_dolog (name
, strlen (name
), 0, 0);
1025 message_dolog (": ", 2, 0, 0);
1028 errname
= Fcar (data
);
1030 if (EQ (errname
, Qerror
))
1035 errmsg
= Fcar (data
);
1040 Lisp_Object error_conditions
;
1041 errmsg
= Fget (errname
, Qerror_message
);
1042 error_conditions
= Fget (errname
, Qerror_conditions
);
1043 file_error
= Fmemq (Qfile_error
, error_conditions
);
1046 /* Print an error message including the data items. */
1048 tail
= Fcdr_safe (data
);
1051 /* For file-error, make error message by concatenating
1052 all the data items. They are all strings. */
1053 if (!NILP (file_error
) && CONSP (tail
))
1054 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
1056 if (STRINGP (errmsg
))
1057 Fprinc (errmsg
, stream
);
1059 write_string_1 ("peculiar error", -1, stream
);
1061 for (i
= 0; CONSP (tail
); tail
= XCDR (tail
), i
++)
1065 write_string_1 (i
? ", " : ": ", 2, stream
);
1067 if (!NILP (file_error
) || EQ (errname
, Qend_of_file
))
1068 Fprinc (obj
, stream
);
1070 Fprin1 (obj
, stream
);
1079 * The buffer should be at least as large as the max string size of the
1080 * largest float, printed in the biggest notation. This is undoubtedly
1081 * 20d float_output_format, with the negative of the C-constant "HUGE"
1084 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
1086 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
1087 * case of -1e307 in 20d float_output_format. What is one to do (short of
1088 * re-writing _doprnt to be more sane)?
1093 float_to_string (buf
, data
)
1100 /* Check for plus infinity in a way that won't lose
1101 if there is no plus infinity. */
1102 if (data
== data
/ 2 && data
> 1.0)
1104 strcpy (buf
, "1.0e+INF");
1107 /* Likewise for minus infinity. */
1108 if (data
== data
/ 2 && data
< -1.0)
1110 strcpy (buf
, "-1.0e+INF");
1113 /* Check for NaN in a way that won't fail if there are no NaNs. */
1114 if (! (data
* 0.0 >= 0.0))
1116 /* Prepend "-" if the NaN's sign bit is negative.
1117 The sign bit of a double is the bit that is 1 in -0.0. */
1119 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
1121 u_minus_zero
.d
= - 0.0;
1122 for (i
= 0; i
< sizeof (double); i
++)
1123 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
1129 strcpy (buf
, "0.0e+NaN");
1133 if (NILP (Vfloat_output_format
)
1134 || !STRINGP (Vfloat_output_format
))
1137 /* Generate the fewest number of digits that represent the
1138 floating point value without losing information.
1139 The following method is simple but a bit slow.
1140 For ideas about speeding things up, please see:
1142 Guy L Steele Jr & Jon L White, How to print floating-point numbers
1143 accurately. SIGPLAN notices 25, 6 (June 1990), 112-126.
1145 Robert G Burger & R Kent Dybvig, Printing floating point numbers
1146 quickly and accurately, SIGPLAN notices 31, 5 (May 1996), 108-116. */
1148 width
= fabs (data
) < DBL_MIN
? 1 : DBL_DIG
;
1150 sprintf (buf
, "%.*g", width
, data
);
1151 while (width
++ < DOUBLE_DIGITS_BOUND
&& atof (buf
) != data
);
1153 else /* oink oink */
1155 /* Check that the spec we have is fully valid.
1156 This means not only valid for printf,
1157 but meant for floats, and reasonable. */
1158 cp
= SDATA (Vfloat_output_format
);
1167 /* Check the width specification. */
1169 if ('0' <= *cp
&& *cp
<= '9')
1173 width
= (width
* 10) + (*cp
++ - '0');
1174 while (*cp
>= '0' && *cp
<= '9');
1176 /* A precision of zero is valid only for %f. */
1178 || (width
== 0 && *cp
!= 'f'))
1182 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1188 sprintf (buf
, SDATA (Vfloat_output_format
), data
);
1191 /* Make sure there is a decimal point with digit after, or an
1192 exponent, so that the value is readable as a float. But don't do
1193 this with "%.0f"; it's valid for that not to produce a decimal
1194 point. Note that width can be 0 only for %.0f. */
1197 for (cp
= buf
; *cp
; cp
++)
1198 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1201 if (*cp
== '.' && cp
[1] == 0)
1218 print (obj
, printcharfun
, escapeflag
)
1220 register Lisp_Object printcharfun
;
1223 old_backquote_output
= 0;
1225 /* Reset print_number_index and Vprint_number_table only when
1226 the variable Vprint_continuous_numbering is nil. Otherwise,
1227 the values of these variables will be kept between several
1229 if (NILP (Vprint_continuous_numbering
))
1231 print_number_index
= 0;
1232 Vprint_number_table
= Qnil
;
1235 /* Construct Vprint_number_table for print-gensym and print-circle. */
1236 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1238 int i
, start
, index
;
1239 start
= index
= print_number_index
;
1240 /* Construct Vprint_number_table.
1241 This increments print_number_index for the objects added. */
1243 print_preprocess (obj
);
1245 /* Remove unnecessary objects, which appear only once in OBJ;
1246 that is, whose status is Qnil. Compactify the necessary objects. */
1247 for (i
= start
; i
< print_number_index
; i
++)
1248 if (!NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1250 PRINT_NUMBER_OBJECT (Vprint_number_table
, index
)
1251 = PRINT_NUMBER_OBJECT (Vprint_number_table
, i
);
1255 /* Clear out objects outside the active part of the table. */
1256 for (i
= index
; i
< print_number_index
; i
++)
1257 PRINT_NUMBER_OBJECT (Vprint_number_table
, i
) = Qnil
;
1259 /* Reset the status field for the next print step. Now this
1260 field means whether the object has already been printed. */
1261 for (i
= start
; i
< print_number_index
; i
++)
1262 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qnil
;
1264 print_number_index
= index
;
1268 print_object (obj
, printcharfun
, escapeflag
);
1271 /* Construct Vprint_number_table according to the structure of OBJ.
1272 OBJ itself and all its elements will be added to Vprint_number_table
1273 recursively if it is a list, vector, compiled function, char-table,
1274 string (its text properties will be traced), or a symbol that has
1275 no obarray (this is for the print-gensym feature).
1276 The status fields of Vprint_number_table mean whether each object appears
1277 more than once in OBJ: Qnil at the first time, and Qt after that . */
1279 print_preprocess (obj
)
1285 Lisp_Object halftail
;
1287 /* Give up if we go so deep that print_object will get an error. */
1288 /* See similar code in print_object. */
1289 if (print_depth
>= PRINT_CIRCLE
)
1292 /* Avoid infinite recursion for circular nested structure
1293 in the case where Vprint_circle is nil. */
1294 if (NILP (Vprint_circle
))
1296 for (i
= 0; i
< print_depth
; i
++)
1297 if (EQ (obj
, being_printed
[i
]))
1299 being_printed
[print_depth
] = obj
;
1306 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1307 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
)
1308 || (! NILP (Vprint_gensym
)
1310 && !SYMBOL_INTERNED_P (obj
)))
1312 /* In case print-circle is nil and print-gensym is t,
1313 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1314 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1316 for (i
= 0; i
< print_number_index
; i
++)
1317 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
), obj
))
1319 /* OBJ appears more than once. Let's remember that. */
1320 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1324 /* OBJ is not yet recorded. Let's add to the table. */
1325 if (print_number_index
== 0)
1327 /* Initialize the table. */
1328 Vprint_number_table
= Fmake_vector (make_number (40), Qnil
);
1330 else if (XVECTOR (Vprint_number_table
)->size
== print_number_index
* 2)
1332 /* Reallocate the table. */
1333 int i
= print_number_index
* 4;
1334 Lisp_Object old_table
= Vprint_number_table
;
1335 Vprint_number_table
= Fmake_vector (make_number (i
), Qnil
);
1336 for (i
= 0; i
< print_number_index
; i
++)
1338 PRINT_NUMBER_OBJECT (Vprint_number_table
, i
)
1339 = PRINT_NUMBER_OBJECT (old_table
, i
);
1340 PRINT_NUMBER_STATUS (Vprint_number_table
, i
)
1341 = PRINT_NUMBER_STATUS (old_table
, i
);
1344 PRINT_NUMBER_OBJECT (Vprint_number_table
, print_number_index
) = obj
;
1345 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1346 always print the gensym with a number. This is a special for
1347 the lisp function byte-compile-output-docform. */
1348 if (!NILP (Vprint_continuous_numbering
)
1350 && !SYMBOL_INTERNED_P (obj
))
1351 PRINT_NUMBER_STATUS (Vprint_number_table
, print_number_index
) = Qt
;
1352 print_number_index
++;
1355 switch (XGCTYPE (obj
))
1358 /* A string may have text properties, which can be circular. */
1359 traverse_intervals_noorder (STRING_INTERVALS (obj
),
1360 print_preprocess_string
, Qnil
);
1364 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1365 just as in print_object. */
1366 if (loop_count
&& EQ (obj
, halftail
))
1368 print_preprocess (XCAR (obj
));
1371 if (!(loop_count
& 1))
1372 halftail
= XCDR (halftail
);
1375 case Lisp_Vectorlike
:
1376 size
= XVECTOR (obj
)->size
;
1377 if (size
& PSEUDOVECTOR_FLAG
)
1378 size
&= PSEUDOVECTOR_SIZE_MASK
;
1379 for (i
= 0; i
< size
; i
++)
1380 print_preprocess (XVECTOR (obj
)->contents
[i
]);
1391 print_preprocess_string (interval
, arg
)
1395 print_preprocess (interval
->plist
);
1398 /* A flag to control printing of `charset' text property.
1399 The default value is Qdefault. */
1400 Lisp_Object Vprint_charset_text_property
;
1401 extern Lisp_Object Qdefault
;
1403 static void print_check_string_charset_prop ();
1405 #define PRINT_STRING_NON_CHARSET_FOUND 1
1406 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1408 /* Bitwize or of the abobe macros. */
1409 static int print_check_string_result
;
1412 print_check_string_charset_prop (interval
, string
)
1418 if (NILP (interval
->plist
)
1419 || (print_check_string_result
== (PRINT_STRING_NON_CHARSET_FOUND
1420 | PRINT_STRING_UNSAFE_CHARSET_FOUND
)))
1422 for (val
= interval
->plist
; CONSP (val
) && ! EQ (XCAR (val
), Qcharset
);
1423 val
= XCDR (XCDR (val
)));
1426 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1429 if (! (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
))
1431 if (! EQ (val
, interval
->plist
)
1432 || CONSP (XCDR (XCDR (val
))))
1433 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1435 if (NILP (Vprint_charset_text_property
)
1436 || ! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1439 int charpos
= interval
->position
;
1440 int bytepos
= string_char_to_byte (string
, charpos
);
1441 Lisp_Object charset
;
1443 charset
= XCAR (XCDR (val
));
1444 for (i
= 0; i
< LENGTH (interval
); i
++)
1446 FETCH_STRING_CHAR_ADVANCE (c
, string
, charpos
, bytepos
);
1447 if (! ASCII_CHAR_P (c
)
1448 && ! EQ (CHARSET_NAME (CHAR_CHARSET (c
)), charset
))
1450 print_check_string_result
|= PRINT_STRING_UNSAFE_CHARSET_FOUND
;
1457 /* The value is (charset . nil). */
1458 static Lisp_Object print_prune_charset_plist
;
1461 print_prune_string_charset (string
)
1464 print_check_string_result
= 0;
1465 traverse_intervals (STRING_INTERVALS (string
), 0,
1466 print_check_string_charset_prop
, string
);
1467 if (! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1469 string
= Fcopy_sequence (string
);
1470 if (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
)
1472 if (NILP (print_prune_charset_plist
))
1473 print_prune_charset_plist
= Fcons (Qcharset
, Qnil
);
1474 Fremove_text_properties (make_number (0),
1475 make_number (SCHARS (string
)),
1476 print_prune_charset_plist
, string
);
1479 Fset_text_properties (make_number (0), make_number (SCHARS (string
)),
1486 print_object (obj
, printcharfun
, escapeflag
)
1488 register Lisp_Object printcharfun
;
1495 /* Detect circularities and truncate them. */
1496 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1497 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
)
1498 || (! NILP (Vprint_gensym
)
1500 && !SYMBOL_INTERNED_P (obj
)))
1502 if (NILP (Vprint_circle
) && NILP (Vprint_gensym
))
1504 /* Simple but incomplete way. */
1506 for (i
= 0; i
< print_depth
; i
++)
1507 if (EQ (obj
, being_printed
[i
]))
1509 sprintf (buf
, "#%d", i
);
1510 strout (buf
, -1, -1, printcharfun
, 0);
1513 being_printed
[print_depth
] = obj
;
1517 /* With the print-circle feature. */
1519 for (i
= 0; i
< print_number_index
; i
++)
1520 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
), obj
))
1522 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1524 /* Add a prefix #n= if OBJ has not yet been printed;
1525 that is, its status field is nil. */
1526 sprintf (buf
, "#%d=", i
+ 1);
1527 strout (buf
, -1, -1, printcharfun
, 0);
1528 /* OBJ is going to be printed. Set the status to t. */
1529 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1534 /* Just print #n# if OBJ has already been printed. */
1535 sprintf (buf
, "#%d#", i
+ 1);
1536 strout (buf
, -1, -1, printcharfun
, 0);
1545 /* See similar code in print_preprocess. */
1546 if (print_depth
> PRINT_CIRCLE
)
1547 error ("Apparently circular structure being printed");
1548 #ifdef MAX_PRINT_CHARS
1549 if (max_print
&& print_chars
> max_print
)
1554 #endif /* MAX_PRINT_CHARS */
1556 switch (XGCTYPE (obj
))
1559 if (sizeof (int) == sizeof (EMACS_INT
))
1560 sprintf (buf
, "%d", XINT (obj
));
1561 else if (sizeof (long) == sizeof (EMACS_INT
))
1562 sprintf (buf
, "%ld", (long) XINT (obj
));
1565 strout (buf
, -1, -1, printcharfun
, 0);
1570 char pigbuf
[350]; /* see comments in float_to_string */
1572 float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1573 strout (pigbuf
, -1, -1, printcharfun
, 0);
1579 print_string (obj
, printcharfun
);
1582 register int i
, i_byte
;
1583 struct gcpro gcpro1
;
1586 /* 1 means we must ensure that the next character we output
1587 cannot be taken as part of a hex character escape. */
1588 int need_nonhex
= 0;
1589 int multibyte
= STRING_MULTIBYTE (obj
);
1593 if (! EQ (Vprint_charset_text_property
, Qt
))
1594 obj
= print_prune_string_charset (obj
);
1596 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1604 size_byte
= SBYTES (obj
);
1606 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1608 /* Here, we must convert each multi-byte form to the
1609 corresponding character code before handing it to PRINTCHAR. */
1615 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
,
1616 size_byte
- i_byte
, len
);
1624 if (c
== '\n' && print_escape_newlines
)
1629 else if (c
== '\f' && print_escape_newlines
)
1635 && (CHAR_BYTE8_P (c
)
1636 || (! ASCII_CHAR_P (c
) && print_escape_multibyte
)))
1638 /* When multibyte is disabled,
1639 print multibyte string chars using hex escapes.
1640 For a char code that could be in a unibyte string,
1641 when found in a multibyte string, always use a hex escape
1642 so it reads back as multibyte. */
1643 unsigned char outbuf
[50];
1645 if (CHAR_BYTE8_P (c
))
1646 sprintf (outbuf
, "\\%03o", CHAR_TO_BYTE8 (c
));
1649 sprintf (outbuf
, "\\x%04x", c
);
1652 strout (outbuf
, -1, -1, printcharfun
, 0);
1654 else if (! multibyte
1655 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1656 && print_escape_nonascii
)
1658 /* When printing in a multibyte buffer
1659 or when explicitly requested,
1660 print single-byte non-ASCII string chars
1661 using octal escapes. */
1662 unsigned char outbuf
[5];
1663 sprintf (outbuf
, "\\%03o", c
);
1664 strout (outbuf
, -1, -1, printcharfun
, 0);
1668 /* If we just had a hex escape, and this character
1669 could be taken as part of it,
1670 output `\ ' to prevent that. */
1674 if ((c
>= 'a' && c
<= 'f')
1675 || (c
>= 'A' && c
<= 'F')
1676 || (c
>= '0' && c
<= '9'))
1677 strout ("\\ ", -1, -1, printcharfun
, 0);
1680 if (c
== '\"' || c
== '\\')
1687 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1689 traverse_intervals (STRING_INTERVALS (obj
),
1690 0, print_interval
, printcharfun
);
1700 register int confusing
;
1701 register unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1702 register unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1704 int i
, i_byte
, size_byte
;
1707 name
= SYMBOL_NAME (obj
);
1709 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1712 /* If symbol name begins with a digit, and ends with a digit,
1713 and contains nothing but digits and `e', it could be treated
1714 as a number. So set CONFUSING.
1716 Symbols that contain periods could also be taken as numbers,
1717 but periods are always escaped, so we don't have to worry
1719 else if (*p
>= '0' && *p
<= '9'
1720 && end
[-1] >= '0' && end
[-1] <= '9')
1722 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1723 /* Needed for \2e10. */
1726 confusing
= (end
== p
);
1731 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1737 size_byte
= SBYTES (name
);
1739 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1741 /* Here, we must convert each multi-byte form to the
1742 corresponding character code before handing it to PRINTCHAR. */
1743 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1748 if (c
== '\"' || c
== '\\' || c
== '\''
1749 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1750 || c
== ',' || c
=='.' || c
== '`'
1751 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1753 PRINTCHAR ('\\'), confusing
= 0;
1761 /* If deeper than spec'd depth, print placeholder. */
1762 if (INTEGERP (Vprint_level
)
1763 && print_depth
> XINT (Vprint_level
))
1764 strout ("...", -1, -1, printcharfun
, 0);
1765 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1766 && (EQ (XCAR (obj
), Qquote
)))
1769 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1771 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1772 && (EQ (XCAR (obj
), Qfunction
)))
1776 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1778 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1779 && ! old_backquote_output
1780 && ((EQ (XCAR (obj
), Qbackquote
)
1781 || EQ (XCAR (obj
), Qcomma
)
1782 || EQ (XCAR (obj
), Qcomma_at
)
1783 || EQ (XCAR (obj
), Qcomma_dot
))))
1785 print_object (XCAR (obj
), printcharfun
, 0);
1786 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1792 /* If the first element is a backquote form,
1793 print it old-style so it won't be misunderstood. */
1794 if (print_quoted
&& CONSP (XCAR (obj
))
1795 && CONSP (XCDR (XCAR (obj
)))
1796 && NILP (XCDR (XCDR (XCAR (obj
))))
1797 && EQ (XCAR (XCAR (obj
)), Qbackquote
))
1803 print_object (Qbackquote
, printcharfun
, 0);
1806 ++old_backquote_output
;
1807 print_object (XCAR (XCDR (tem
)), printcharfun
, 0);
1808 --old_backquote_output
;
1815 int print_length
, i
;
1816 Lisp_Object halftail
= obj
;
1818 /* Negative values of print-length are invalid in CL.
1819 Treat them like nil, as CMUCL does. */
1820 if (NATNUMP (Vprint_length
))
1821 print_length
= XFASTINT (Vprint_length
);
1828 /* Detect circular list. */
1829 if (NILP (Vprint_circle
))
1831 /* Simple but imcomplete way. */
1832 if (i
!= 0 && EQ (obj
, halftail
))
1834 sprintf (buf
, " . #%d", i
/ 2);
1835 strout (buf
, -1, -1, printcharfun
, 0);
1841 /* With the print-circle feature. */
1845 for (i
= 0; i
< print_number_index
; i
++)
1846 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
),
1849 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1851 strout (" . ", 3, 3, printcharfun
, 0);
1852 print_object (obj
, printcharfun
, escapeflag
);
1856 sprintf (buf
, " . #%d#", i
+ 1);
1857 strout (buf
, -1, -1, printcharfun
, 0);
1867 if (print_length
&& i
> print_length
)
1869 strout ("...", 3, 3, printcharfun
, 0);
1873 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1877 halftail
= XCDR (halftail
);
1881 /* OBJ non-nil here means it's the end of a dotted list. */
1884 strout (" . ", 3, 3, printcharfun
, 0);
1885 print_object (obj
, printcharfun
, escapeflag
);
1893 case Lisp_Vectorlike
:
1898 strout ("#<process ", -1, -1, printcharfun
, 0);
1899 print_string (XPROCESS (obj
)->name
, printcharfun
);
1903 print_string (XPROCESS (obj
)->name
, printcharfun
);
1905 else if (BOOL_VECTOR_P (obj
))
1908 register unsigned char c
;
1909 struct gcpro gcpro1
;
1911 = ((XBOOL_VECTOR (obj
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
1912 / BOOL_VECTOR_BITS_PER_CHAR
);
1918 sprintf (buf
, "%ld", (long) XBOOL_VECTOR (obj
)->size
);
1919 strout (buf
, -1, -1, printcharfun
, 0);
1922 /* Don't print more characters than the specified maximum.
1923 Negative values of print-length are invalid. Treat them
1924 like a print-length of nil. */
1925 if (NATNUMP (Vprint_length
)
1926 && XFASTINT (Vprint_length
) < size_in_chars
)
1927 size_in_chars
= XFASTINT (Vprint_length
);
1929 for (i
= 0; i
< size_in_chars
; i
++)
1932 c
= XBOOL_VECTOR (obj
)->data
[i
];
1933 if (! ASCII_BYTE_P (c
))
1935 sprintf (buf
, "\\%03o", c
);
1936 strout (buf
, -1, -1, printcharfun
, 0);
1938 else if (c
== '\n' && print_escape_newlines
)
1943 else if (c
== '\f' && print_escape_newlines
)
1948 else if (c
> '\177')
1950 /* Use octal escapes to avoid encoding issues. */
1952 PRINTCHAR ('0' + ((c
>> 6) & 3));
1953 PRINTCHAR ('0' + ((c
>> 3) & 7));
1954 PRINTCHAR ('0' + (c
& 7));
1958 if (c
== '\"' || c
== '\\')
1967 else if (SUBRP (obj
))
1969 strout ("#<subr ", -1, -1, printcharfun
, 0);
1970 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
, 0);
1973 else if (WINDOWP (obj
))
1975 strout ("#<window ", -1, -1, printcharfun
, 0);
1976 sprintf (buf
, "%ld", (long) XFASTINT (XWINDOW (obj
)->sequence_number
));
1977 strout (buf
, -1, -1, printcharfun
, 0);
1978 if (!NILP (XWINDOW (obj
)->buffer
))
1980 strout (" on ", -1, -1, printcharfun
, 0);
1981 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1985 else if (HASH_TABLE_P (obj
))
1987 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1988 strout ("#<hash-table", -1, -1, printcharfun
, 0);
1989 if (SYMBOLP (h
->test
))
1993 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
, 0);
1995 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
, 0);
1997 sprintf (buf
, "%ld/%ld", (long) XFASTINT (h
->count
),
1998 (long) XVECTOR (h
->next
)->size
);
1999 strout (buf
, -1, -1, printcharfun
, 0);
2001 sprintf (buf
, " 0x%lx", (unsigned long) h
);
2002 strout (buf
, -1, -1, printcharfun
, 0);
2005 else if (BUFFERP (obj
))
2007 if (NILP (XBUFFER (obj
)->name
))
2008 strout ("#<killed buffer>", -1, -1, printcharfun
, 0);
2009 else if (escapeflag
)
2011 strout ("#<buffer ", -1, -1, printcharfun
, 0);
2012 print_string (XBUFFER (obj
)->name
, printcharfun
);
2016 print_string (XBUFFER (obj
)->name
, printcharfun
);
2018 else if (WINDOW_CONFIGURATIONP (obj
))
2020 strout ("#<window-configuration>", -1, -1, printcharfun
, 0);
2022 else if (FRAMEP (obj
))
2024 strout ((FRAME_LIVE_P (XFRAME (obj
))
2025 ? "#<frame " : "#<dead frame "),
2026 -1, -1, printcharfun
, 0);
2027 print_string (XFRAME (obj
)->name
, printcharfun
);
2028 sprintf (buf
, " 0x%lx", (unsigned long) (XFRAME (obj
)));
2029 strout (buf
, -1, -1, printcharfun
, 0);
2034 EMACS_INT size
= XVECTOR (obj
)->size
;
2035 if (COMPILEDP (obj
))
2038 size
&= PSEUDOVECTOR_SIZE_MASK
;
2040 if (CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
))
2042 /* We print a char-table as if it were a vector,
2043 lumping the parent and default slots in with the
2044 character slots. But we add #^ as a prefix. */
2047 if (SUB_CHAR_TABLE_P (obj
))
2049 size
&= PSEUDOVECTOR_SIZE_MASK
;
2051 if (size
& PSEUDOVECTOR_FLAG
)
2057 register Lisp_Object tem
;
2058 int real_size
= size
;
2060 /* Don't print more elements than the specified maximum. */
2061 if (NATNUMP (Vprint_length
)
2062 && XFASTINT (Vprint_length
) < size
)
2063 size
= XFASTINT (Vprint_length
);
2065 for (i
= 0; i
< size
; i
++)
2067 if (i
) PRINTCHAR (' ');
2068 tem
= XVECTOR (obj
)->contents
[i
];
2069 print_object (tem
, printcharfun
, escapeflag
);
2071 if (size
< real_size
)
2072 strout (" ...", 4, 4, printcharfun
, 0);
2079 switch (XMISCTYPE (obj
))
2081 case Lisp_Misc_Marker
:
2082 strout ("#<marker ", -1, -1, printcharfun
, 0);
2083 /* Do you think this is necessary? */
2084 if (XMARKER (obj
)->insertion_type
!= 0)
2085 strout ("(moves after insertion) ", -1, -1, printcharfun
, 0);
2086 if (!(XMARKER (obj
)->buffer
))
2087 strout ("in no buffer", -1, -1, printcharfun
, 0);
2090 sprintf (buf
, "at %d", marker_position (obj
));
2091 strout (buf
, -1, -1, printcharfun
, 0);
2092 strout (" in ", -1, -1, printcharfun
, 0);
2093 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
2098 case Lisp_Misc_Overlay
:
2099 strout ("#<overlay ", -1, -1, printcharfun
, 0);
2100 if (!(XMARKER (OVERLAY_START (obj
))->buffer
))
2101 strout ("in no buffer", -1, -1, printcharfun
, 0);
2104 sprintf (buf
, "from %d to %d in ",
2105 marker_position (OVERLAY_START (obj
)),
2106 marker_position (OVERLAY_END (obj
)));
2107 strout (buf
, -1, -1, printcharfun
, 0);
2108 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
2114 /* Remaining cases shouldn't happen in normal usage, but let's print
2115 them anyway for the benefit of the debugger. */
2116 case Lisp_Misc_Free
:
2117 strout ("#<misc free cell>", -1, -1, printcharfun
, 0);
2120 case Lisp_Misc_Intfwd
:
2121 sprintf (buf
, "#<intfwd to %ld>", (long) *XINTFWD (obj
)->intvar
);
2122 strout (buf
, -1, -1, printcharfun
, 0);
2125 case Lisp_Misc_Boolfwd
:
2126 sprintf (buf
, "#<boolfwd to %s>",
2127 (*XBOOLFWD (obj
)->boolvar
? "t" : "nil"));
2128 strout (buf
, -1, -1, printcharfun
, 0);
2131 case Lisp_Misc_Objfwd
:
2132 strout ("#<objfwd to ", -1, -1, printcharfun
, 0);
2133 print_object (*XOBJFWD (obj
)->objvar
, printcharfun
, escapeflag
);
2137 case Lisp_Misc_Buffer_Objfwd
:
2138 strout ("#<buffer_objfwd to ", -1, -1, printcharfun
, 0);
2139 print_object (PER_BUFFER_VALUE (current_buffer
,
2140 XBUFFER_OBJFWD (obj
)->offset
),
2141 printcharfun
, escapeflag
);
2145 case Lisp_Misc_Kboard_Objfwd
:
2146 strout ("#<kboard_objfwd to ", -1, -1, printcharfun
, 0);
2147 print_object (*(Lisp_Object
*)((char *) current_kboard
2148 + XKBOARD_OBJFWD (obj
)->offset
),
2149 printcharfun
, escapeflag
);
2153 case Lisp_Misc_Buffer_Local_Value
:
2154 strout ("#<buffer_local_value ", -1, -1, printcharfun
, 0);
2155 goto do_buffer_local
;
2156 case Lisp_Misc_Some_Buffer_Local_Value
:
2157 strout ("#<some_buffer_local_value ", -1, -1, printcharfun
, 0);
2159 strout ("[realvalue] ", -1, -1, printcharfun
, 0);
2160 print_object (XBUFFER_LOCAL_VALUE (obj
)->realvalue
,
2161 printcharfun
, escapeflag
);
2162 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_buffer
)
2163 strout ("[local in buffer] ", -1, -1, printcharfun
, 0);
2165 strout ("[buffer] ", -1, -1, printcharfun
, 0);
2166 print_object (XBUFFER_LOCAL_VALUE (obj
)->buffer
,
2167 printcharfun
, escapeflag
);
2168 if (XBUFFER_LOCAL_VALUE (obj
)->check_frame
)
2170 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_frame
)
2171 strout ("[local in frame] ", -1, -1, printcharfun
, 0);
2173 strout ("[frame] ", -1, -1, printcharfun
, 0);
2174 print_object (XBUFFER_LOCAL_VALUE (obj
)->frame
,
2175 printcharfun
, escapeflag
);
2177 strout ("[alist-elt] ", -1, -1, printcharfun
, 0);
2178 print_object (XCAR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
2179 printcharfun
, escapeflag
);
2180 strout ("[default-value] ", -1, -1, printcharfun
, 0);
2181 print_object (XCDR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
2182 printcharfun
, escapeflag
);
2194 /* We're in trouble if this happens!
2195 Probably should just abort () */
2196 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
, 0);
2198 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2199 else if (VECTORLIKEP (obj
))
2200 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
2202 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2203 strout (buf
, -1, -1, printcharfun
, 0);
2204 strout (" Save your buffers immediately and please report this bug>",
2205 -1, -1, printcharfun
, 0);
2213 /* Print a description of INTERVAL using PRINTCHARFUN.
2214 This is part of printing a string that has text properties. */
2217 print_interval (interval
, printcharfun
)
2219 Lisp_Object printcharfun
;
2221 if (NILP (interval
->plist
))
2224 print_object (make_number (interval
->position
), printcharfun
, 1);
2226 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2229 print_object (interval
->plist
, printcharfun
, 1);
2236 Qtemp_buffer_setup_hook
= intern ("temp-buffer-setup-hook");
2237 staticpro (&Qtemp_buffer_setup_hook
);
2239 DEFVAR_LISP ("standard-output", &Vstandard_output
,
2240 doc
: /* Output stream `print' uses by default for outputting a character.
2241 This may be any function of one argument.
2242 It may also be a buffer (output is inserted before point)
2243 or a marker (output is inserted and the marker is advanced)
2244 or the symbol t (output appears in the echo area). */);
2245 Vstandard_output
= Qt
;
2246 Qstandard_output
= intern ("standard-output");
2247 staticpro (&Qstandard_output
);
2249 DEFVAR_LISP ("float-output-format", &Vfloat_output_format
,
2250 doc
: /* The format descriptor string used to print floats.
2251 This is a %-spec like those accepted by `printf' in C,
2252 but with some restrictions. It must start with the two characters `%.'.
2253 After that comes an integer precision specification,
2254 and then a letter which controls the format.
2255 The letters allowed are `e', `f' and `g'.
2256 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2257 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2258 Use `g' to choose the shorter of those two formats for the number at hand.
2259 The precision in any of these cases is the number of digits following
2260 the decimal point. With `f', a precision of 0 means to omit the
2261 decimal point. 0 is not allowed with `e' or `g'.
2263 A value of nil means to use the shortest notation
2264 that represents the number without losing information. */);
2265 Vfloat_output_format
= Qnil
;
2266 Qfloat_output_format
= intern ("float-output-format");
2267 staticpro (&Qfloat_output_format
);
2269 DEFVAR_LISP ("print-length", &Vprint_length
,
2270 doc
: /* Maximum length of list to print before abbreviating.
2271 A value of nil means no limit. See also `eval-expression-print-length'. */);
2272 Vprint_length
= Qnil
;
2274 DEFVAR_LISP ("print-level", &Vprint_level
,
2275 doc
: /* Maximum depth of list nesting to print before abbreviating.
2276 A value of nil means no limit. See also `eval-expression-print-level'. */);
2277 Vprint_level
= Qnil
;
2279 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines
,
2280 doc
: /* Non-nil means print newlines in strings as `\\n'.
2281 Also print formfeeds as `\\f'. */);
2282 print_escape_newlines
= 0;
2284 DEFVAR_BOOL ("print-escape-nonascii", &print_escape_nonascii
,
2285 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2286 \(OOO is the octal representation of the character code.)
2287 Only single-byte characters are affected, and only in `prin1'.
2288 When the output goes in a multibyte buffer, this feature is
2289 enabled regardless of the value of the variable. */);
2290 print_escape_nonascii
= 0;
2292 DEFVAR_BOOL ("print-escape-multibyte", &print_escape_multibyte
,
2293 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2294 \(XXXX is the hex representation of the character code.)
2295 This affects only `prin1'. */);
2296 print_escape_multibyte
= 0;
2298 DEFVAR_BOOL ("print-quoted", &print_quoted
,
2299 doc
: /* Non-nil means print quoted forms with reader syntax.
2300 I.e., (quote foo) prints as 'foo, (function foo) as #'foo, and backquoted
2301 forms print as in the new syntax. */);
2304 DEFVAR_LISP ("print-gensym", &Vprint_gensym
,
2305 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2306 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2307 When the uninterned symbol appears within a recursive data structure,
2308 and the symbol appears more than once, in addition use the #N# and #N=
2309 constructs as needed, so that multiple references to the same symbol are
2310 shared once again when the text is read back. */);
2311 Vprint_gensym
= Qnil
;
2313 DEFVAR_LISP ("print-circle", &Vprint_circle
,
2314 doc
: /* *Non-nil means print recursive structures using #N= and #N# syntax.
2315 If nil, printing proceeds recursively and may lead to
2316 `max-lisp-eval-depth' being exceeded or an error may occur:
2317 \"Apparently circular structure being printed.\" Also see
2318 `print-length' and `print-level'.
2319 If non-nil, shared substructures anywhere in the structure are printed
2320 with `#N=' before the first occurrence (in the order of the print
2321 representation) and `#N#' in place of each subsequent occurrence,
2322 where N is a positive decimal integer. */);
2323 Vprint_circle
= Qnil
;
2325 DEFVAR_LISP ("print-continuous-numbering", &Vprint_continuous_numbering
,
2326 doc
: /* *Non-nil means number continuously across print calls.
2327 This affects the numbers printed for #N= labels and #M# references.
2328 See also `print-circle', `print-gensym', and `print-number-table'.
2329 This variable should not be set with `setq'; bind it with a `let' instead. */);
2330 Vprint_continuous_numbering
= Qnil
;
2332 DEFVAR_LISP ("print-number-table", &Vprint_number_table
,
2333 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2334 The Lisp printer uses this vector to detect Lisp objects referenced more
2337 When you bind `print-continuous-numbering' to t, you should probably
2338 also bind `print-number-table' to nil. This ensures that the value of
2339 `print-number-table' can be garbage-collected once the printing is
2340 done. If all elements of `print-number-table' are nil, it means that
2341 the printing done so far has not found any shared structure or objects
2342 that need to be recorded in the table. */);
2343 Vprint_number_table
= Qnil
;
2345 DEFVAR_LISP ("print-charset-text-property", &Vprint_charset_text_property
,
2346 doc
: /* A flag to control printing of `charset' text property on printing a string.
2347 The value must be nil, t, or `default'.
2349 If the value is nil, don't print the text property `charset'.
2351 If the value is t, always print the text property `charset'.
2353 If the value is `default', print the text property `charset' only when
2354 the value is different from what is guessed in the current charset
2356 Vprint_charset_text_property
= Qdefault
;
2358 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2359 staticpro (&Vprin1_to_string_buffer
);
2362 defsubr (&Sprin1_to_string
);
2363 defsubr (&Serror_message_string
);
2367 defsubr (&Swrite_char
);
2368 defsubr (&Sexternal_debugging_output
);
2369 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2370 defsubr (&Sredirect_debugging_output
);
2373 Qexternal_debugging_output
= intern ("external-debugging-output");
2374 staticpro (&Qexternal_debugging_output
);
2376 Qprint_escape_newlines
= intern ("print-escape-newlines");
2377 staticpro (&Qprint_escape_newlines
);
2379 Qprint_escape_multibyte
= intern ("print-escape-multibyte");
2380 staticpro (&Qprint_escape_multibyte
);
2382 Qprint_escape_nonascii
= intern ("print-escape-nonascii");
2383 staticpro (&Qprint_escape_nonascii
);
2385 print_prune_charset_plist
= Qnil
;
2386 staticpro (&print_prune_charset_plist
);
2388 defsubr (&Swith_output_to_temp_buffer
);
2391 /* arch-tag: bc797170-94ae-41de-86e3-75e20f8f7a39
2392 (do not change this comment) */