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. */
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 EMACS_INT marker_pos; \
216 if (!(XMARKER (printcharfun)->buffer)) \
217 error ("Marker does not point anywhere"); \
218 if (XMARKER (printcharfun)->buffer != current_buffer) \
219 set_buffer_internal (XMARKER (printcharfun)->buffer); \
220 marker_pos = marker_position (printcharfun); \
221 if (marker_pos < BEGV || marker_pos > ZV) \
222 error ("Marker is outside the accessible part of the buffer"); \
224 old_point_byte = PT_BYTE; \
225 SET_PT_BOTH (marker_pos, \
226 marker_byte_position (printcharfun)); \
228 start_point_byte = PT_BYTE; \
229 printcharfun = Qnil; \
231 if (NILP (printcharfun)) \
233 Lisp_Object string; \
234 if (NILP (current_buffer->enable_multibyte_characters) \
235 && ! print_escape_multibyte) \
236 specbind (Qprint_escape_multibyte, Qt); \
237 if (! NILP (current_buffer->enable_multibyte_characters) \
238 && ! print_escape_nonascii) \
239 specbind (Qprint_escape_nonascii, Qt); \
240 if (print_buffer != 0) \
242 string = make_string_from_bytes (print_buffer, \
244 print_buffer_pos_byte); \
245 record_unwind_protect (print_unwind, string); \
249 print_buffer_size = 1000; \
250 print_buffer = (char *) xmalloc (print_buffer_size); \
251 free_print_buffer = 1; \
253 print_buffer_pos = 0; \
254 print_buffer_pos_byte = 0; \
256 if (EQ (printcharfun, Qt) && ! noninteractive) \
257 setup_echo_area_for_printing (multibyte);
259 #define PRINTFINISH \
260 if (NILP (printcharfun)) \
262 if (print_buffer_pos != print_buffer_pos_byte \
263 && NILP (current_buffer->enable_multibyte_characters)) \
265 unsigned char *temp \
266 = (unsigned char *) alloca (print_buffer_pos + 1); \
267 copy_text (print_buffer, temp, print_buffer_pos_byte, \
269 insert_1_both (temp, print_buffer_pos, \
270 print_buffer_pos, 0, 1, 0); \
273 insert_1_both (print_buffer, print_buffer_pos, \
274 print_buffer_pos_byte, 0, 1, 0); \
276 if (free_print_buffer) \
278 xfree (print_buffer); \
281 unbind_to (specpdl_count, Qnil); \
282 if (MARKERP (original)) \
283 set_marker_both (original, Qnil, PT, PT_BYTE); \
284 if (old_point >= 0) \
285 SET_PT_BOTH (old_point + (old_point >= start_point \
286 ? PT - start_point : 0), \
287 old_point_byte + (old_point_byte >= start_point_byte \
288 ? PT_BYTE - start_point_byte : 0)); \
289 if (old != current_buffer) \
290 set_buffer_internal (old);
292 #define PRINTCHAR(ch) printchar (ch, printcharfun)
294 /* This is used to restore the saved contents of print_buffer
295 when there is a recursive call to print. */
298 print_unwind (saved_text
)
299 Lisp_Object saved_text
;
301 bcopy (SDATA (saved_text
), print_buffer
, SCHARS (saved_text
));
306 /* Print character CH using method FUN. FUN nil means print to
307 print_buffer. FUN t means print to echo area or stdout if
308 non-interactive. If FUN is neither nil nor t, call FUN with CH as
316 #ifdef MAX_PRINT_CHARS
319 #endif /* MAX_PRINT_CHARS */
321 if (!NILP (fun
) && !EQ (fun
, Qt
))
322 call1 (fun
, make_number (ch
));
325 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
326 int len
= CHAR_STRING (ch
, str
);
332 if (print_buffer_pos_byte
+ len
>= print_buffer_size
)
333 print_buffer
= (char *) xrealloc (print_buffer
,
334 print_buffer_size
*= 2);
335 bcopy (str
, print_buffer
+ print_buffer_pos_byte
, len
);
336 print_buffer_pos
+= 1;
337 print_buffer_pos_byte
+= len
;
339 else if (noninteractive
)
341 fwrite (str
, 1, len
, stdout
);
342 noninteractive_need_newline
= 1;
347 = !NILP (current_buffer
->enable_multibyte_characters
);
349 setup_echo_area_for_printing (multibyte_p
);
351 message_dolog (str
, len
, 0, multibyte_p
);
357 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
358 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
359 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
360 print_buffer. PRINTCHARFUN t means output to the echo area or to
361 stdout if non-interactive. If neither nil nor t, call Lisp
362 function PRINTCHARFUN for each character printed. MULTIBYTE
363 non-zero means PTR contains multibyte characters. */
366 strout (ptr
, size
, size_byte
, printcharfun
, multibyte
)
369 Lisp_Object printcharfun
;
373 size_byte
= size
= strlen (ptr
);
375 if (NILP (printcharfun
))
377 if (print_buffer_pos_byte
+ size_byte
> print_buffer_size
)
379 print_buffer_size
= print_buffer_size
* 2 + size_byte
;
380 print_buffer
= (char *) xrealloc (print_buffer
,
383 bcopy (ptr
, print_buffer
+ print_buffer_pos_byte
, size_byte
);
384 print_buffer_pos
+= size
;
385 print_buffer_pos_byte
+= size_byte
;
387 #ifdef MAX_PRINT_CHARS
390 #endif /* MAX_PRINT_CHARS */
392 else if (noninteractive
&& EQ (printcharfun
, Qt
))
394 fwrite (ptr
, 1, size_byte
, stdout
);
395 noninteractive_need_newline
= 1;
397 else if (EQ (printcharfun
, Qt
))
399 /* Output to echo area. We're trying to avoid a little overhead
400 here, that's the reason we don't call printchar to do the
404 = !NILP (current_buffer
->enable_multibyte_characters
);
406 setup_echo_area_for_printing (multibyte_p
);
407 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
409 if (size
== size_byte
)
411 for (i
= 0; i
< size
; ++i
)
412 insert_char ((unsigned char )*ptr
++);
417 for (i
= 0; i
< size_byte
; i
+= len
)
419 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size_byte
- i
, len
);
424 #ifdef MAX_PRINT_CHARS
427 #endif /* MAX_PRINT_CHARS */
431 /* PRINTCHARFUN is a Lisp function. */
434 if (size
== size_byte
)
436 while (i
< size_byte
)
444 while (i
< size_byte
)
446 /* Here, we must convert each multi-byte form to the
447 corresponding character code before handing it to
450 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size_byte
- i
, len
);
458 /* Print the contents of a string STRING using PRINTCHARFUN.
459 It isn't safe to use strout in many cases,
460 because printing one char can relocate. */
463 print_string (string
, printcharfun
)
465 Lisp_Object printcharfun
;
467 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
471 if (print_escape_nonascii
)
472 string
= string_escape_byte8 (string
);
474 if (STRING_MULTIBYTE (string
))
475 chars
= SCHARS (string
);
476 else if (! print_escape_nonascii
477 && (EQ (printcharfun
, Qt
)
478 ? ! NILP (buffer_defaults
.enable_multibyte_characters
)
479 : ! NILP (current_buffer
->enable_multibyte_characters
)))
481 /* If unibyte string STRING contains 8-bit codes, we must
482 convert STRING to a multibyte string containing the same
487 chars
= SBYTES (string
);
488 bytes
= parse_str_to_multibyte (SDATA (string
), chars
);
491 newstr
= make_uninit_multibyte_string (chars
, bytes
);
492 bcopy (SDATA (string
), SDATA (newstr
), chars
);
493 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
498 chars
= SBYTES (string
);
500 /* strout is safe for output to a frame (echo area) or to print_buffer. */
501 strout (SDATA (string
),
502 chars
, SBYTES (string
),
503 printcharfun
, STRING_MULTIBYTE (string
));
507 /* Otherwise, string may be relocated by printing one char.
508 So re-fetch the string address for each character. */
510 int size
= SCHARS (string
);
511 int size_byte
= SBYTES (string
);
514 if (size
== size_byte
)
515 for (i
= 0; i
< size
; i
++)
516 PRINTCHAR (SREF (string
, i
));
518 for (i
= 0; i
< size_byte
; )
520 /* Here, we must convert each multi-byte form to the
521 corresponding character code before handing it to PRINTCHAR. */
523 int ch
= STRING_CHAR_AND_LENGTH (SDATA (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
);
1402 /* A flag to control printing of `charset' text property.
1403 The default value is Qdefault. */
1404 Lisp_Object Vprint_charset_text_property
;
1405 extern Lisp_Object Qdefault
;
1407 static void print_check_string_charset_prop ();
1409 #define PRINT_STRING_NON_CHARSET_FOUND 1
1410 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1412 /* Bitwize or of the abobe macros. */
1413 static int print_check_string_result
;
1416 print_check_string_charset_prop (interval
, string
)
1422 if (NILP (interval
->plist
)
1423 || (print_check_string_result
== (PRINT_STRING_NON_CHARSET_FOUND
1424 | PRINT_STRING_UNSAFE_CHARSET_FOUND
)))
1426 for (val
= interval
->plist
; CONSP (val
) && ! EQ (XCAR (val
), Qcharset
);
1427 val
= XCDR (XCDR (val
)));
1430 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1433 if (! (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
))
1435 if (! EQ (val
, interval
->plist
)
1436 || CONSP (XCDR (XCDR (val
))))
1437 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1439 if (NILP (Vprint_charset_text_property
)
1440 || ! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1443 int charpos
= interval
->position
;
1444 int bytepos
= string_char_to_byte (string
, charpos
);
1445 Lisp_Object charset
;
1447 charset
= XCAR (XCDR (val
));
1448 for (i
= 0; i
< LENGTH (interval
); i
++)
1450 FETCH_STRING_CHAR_ADVANCE (c
, string
, charpos
, bytepos
);
1451 if (! ASCII_CHAR_P (c
)
1452 && ! EQ (CHARSET_NAME (CHAR_CHARSET (c
)), charset
))
1454 print_check_string_result
|= PRINT_STRING_UNSAFE_CHARSET_FOUND
;
1461 /* The value is (charset . nil). */
1462 static Lisp_Object print_prune_charset_plist
;
1465 print_prune_string_charset (string
)
1468 print_check_string_result
= 0;
1469 traverse_intervals (STRING_INTERVALS (string
), 0,
1470 print_check_string_charset_prop
, string
);
1471 if (! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1473 string
= Fcopy_sequence (string
);
1474 if (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
)
1476 if (NILP (print_prune_charset_plist
))
1477 print_prune_charset_plist
= Fcons (Qcharset
, Qnil
);
1478 Fremove_text_properties (make_number (0),
1479 make_number (SCHARS (string
)),
1480 print_prune_charset_plist
, string
);
1483 Fset_text_properties (make_number (0), make_number (SCHARS (string
)),
1490 print_object (obj
, printcharfun
, escapeflag
)
1492 register Lisp_Object printcharfun
;
1499 /* Detect circularities and truncate them. */
1500 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1501 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
)
1502 || (! NILP (Vprint_gensym
)
1504 && !SYMBOL_INTERNED_P (obj
)))
1506 if (NILP (Vprint_circle
) && NILP (Vprint_gensym
))
1508 /* Simple but incomplete way. */
1510 for (i
= 0; i
< print_depth
; i
++)
1511 if (EQ (obj
, being_printed
[i
]))
1513 sprintf (buf
, "#%d", i
);
1514 strout (buf
, -1, -1, printcharfun
, 0);
1517 being_printed
[print_depth
] = obj
;
1521 /* With the print-circle feature. */
1523 for (i
= 0; i
< print_number_index
; i
++)
1524 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
), obj
))
1526 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1528 /* Add a prefix #n= if OBJ has not yet been printed;
1529 that is, its status field is nil. */
1530 sprintf (buf
, "#%d=", i
+ 1);
1531 strout (buf
, -1, -1, printcharfun
, 0);
1532 /* OBJ is going to be printed. Set the status to t. */
1533 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1538 /* Just print #n# if OBJ has already been printed. */
1539 sprintf (buf
, "#%d#", i
+ 1);
1540 strout (buf
, -1, -1, printcharfun
, 0);
1549 /* See similar code in print_preprocess. */
1550 if (print_depth
> PRINT_CIRCLE
)
1551 error ("Apparently circular structure being printed");
1552 #ifdef MAX_PRINT_CHARS
1553 if (max_print
&& print_chars
> max_print
)
1558 #endif /* MAX_PRINT_CHARS */
1560 switch (XGCTYPE (obj
))
1563 if (sizeof (int) == sizeof (EMACS_INT
))
1564 sprintf (buf
, "%d", XINT (obj
));
1565 else if (sizeof (long) == sizeof (EMACS_INT
))
1566 sprintf (buf
, "%ld", (long) XINT (obj
));
1569 strout (buf
, -1, -1, printcharfun
, 0);
1574 char pigbuf
[350]; /* see comments in float_to_string */
1576 float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1577 strout (pigbuf
, -1, -1, printcharfun
, 0);
1583 print_string (obj
, printcharfun
);
1586 register int i
, i_byte
;
1587 struct gcpro gcpro1
;
1590 /* 1 means we must ensure that the next character we output
1591 cannot be taken as part of a hex character escape. */
1592 int need_nonhex
= 0;
1593 int multibyte
= STRING_MULTIBYTE (obj
);
1597 if (! EQ (Vprint_charset_text_property
, Qt
))
1598 obj
= print_prune_string_charset (obj
);
1600 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1608 size_byte
= SBYTES (obj
);
1610 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1612 /* Here, we must convert each multi-byte form to the
1613 corresponding character code before handing it to PRINTCHAR. */
1619 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
,
1620 size_byte
- i_byte
, len
);
1628 if (c
== '\n' && print_escape_newlines
)
1633 else if (c
== '\f' && print_escape_newlines
)
1639 && (CHAR_BYTE8_P (c
)
1640 || (! ASCII_CHAR_P (c
) && print_escape_multibyte
)))
1642 /* When multibyte is disabled,
1643 print multibyte string chars using hex escapes.
1644 For a char code that could be in a unibyte string,
1645 when found in a multibyte string, always use a hex escape
1646 so it reads back as multibyte. */
1647 unsigned char outbuf
[50];
1649 if (CHAR_BYTE8_P (c
))
1650 sprintf (outbuf
, "\\%03o", CHAR_TO_BYTE8 (c
));
1653 sprintf (outbuf
, "\\x%04x", c
);
1656 strout (outbuf
, -1, -1, printcharfun
, 0);
1658 else if (! multibyte
1659 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1660 && print_escape_nonascii
)
1662 /* When printing in a multibyte buffer
1663 or when explicitly requested,
1664 print single-byte non-ASCII string chars
1665 using octal escapes. */
1666 unsigned char outbuf
[5];
1667 sprintf (outbuf
, "\\%03o", c
);
1668 strout (outbuf
, -1, -1, printcharfun
, 0);
1672 /* If we just had a hex escape, and this character
1673 could be taken as part of it,
1674 output `\ ' to prevent that. */
1678 if ((c
>= 'a' && c
<= 'f')
1679 || (c
>= 'A' && c
<= 'F')
1680 || (c
>= '0' && c
<= '9'))
1681 strout ("\\ ", -1, -1, printcharfun
, 0);
1684 if (c
== '\"' || c
== '\\')
1691 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1693 traverse_intervals (STRING_INTERVALS (obj
),
1694 0, print_interval
, printcharfun
);
1704 register int confusing
;
1705 register unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1706 register unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1708 int i
, i_byte
, size_byte
;
1711 name
= SYMBOL_NAME (obj
);
1713 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1716 /* If symbol name begins with a digit, and ends with a digit,
1717 and contains nothing but digits and `e', it could be treated
1718 as a number. So set CONFUSING.
1720 Symbols that contain periods could also be taken as numbers,
1721 but periods are always escaped, so we don't have to worry
1723 else if (*p
>= '0' && *p
<= '9'
1724 && end
[-1] >= '0' && end
[-1] <= '9')
1726 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1727 /* Needed for \2e10. */
1730 confusing
= (end
== p
);
1735 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1741 size_byte
= SBYTES (name
);
1743 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1745 /* Here, we must convert each multi-byte form to the
1746 corresponding character code before handing it to PRINTCHAR. */
1747 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1752 if (c
== '\"' || c
== '\\' || c
== '\''
1753 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1754 || c
== ',' || c
=='.' || c
== '`'
1755 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1757 PRINTCHAR ('\\'), confusing
= 0;
1765 /* If deeper than spec'd depth, print placeholder. */
1766 if (INTEGERP (Vprint_level
)
1767 && print_depth
> XINT (Vprint_level
))
1768 strout ("...", -1, -1, printcharfun
, 0);
1769 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1770 && (EQ (XCAR (obj
), Qquote
)))
1773 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1775 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1776 && (EQ (XCAR (obj
), Qfunction
)))
1780 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1782 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1783 && ! old_backquote_output
1784 && ((EQ (XCAR (obj
), Qbackquote
)
1785 || EQ (XCAR (obj
), Qcomma
)
1786 || EQ (XCAR (obj
), Qcomma_at
)
1787 || EQ (XCAR (obj
), Qcomma_dot
))))
1789 print_object (XCAR (obj
), printcharfun
, 0);
1790 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1796 /* If the first element is a backquote form,
1797 print it old-style so it won't be misunderstood. */
1798 if (print_quoted
&& CONSP (XCAR (obj
))
1799 && CONSP (XCDR (XCAR (obj
)))
1800 && NILP (XCDR (XCDR (XCAR (obj
))))
1801 && EQ (XCAR (XCAR (obj
)), Qbackquote
))
1807 print_object (Qbackquote
, printcharfun
, 0);
1810 ++old_backquote_output
;
1811 print_object (XCAR (XCDR (tem
)), printcharfun
, 0);
1812 --old_backquote_output
;
1819 int print_length
, i
;
1820 Lisp_Object halftail
= obj
;
1822 /* Negative values of print-length are invalid in CL.
1823 Treat them like nil, as CMUCL does. */
1824 if (NATNUMP (Vprint_length
))
1825 print_length
= XFASTINT (Vprint_length
);
1832 /* Detect circular list. */
1833 if (NILP (Vprint_circle
))
1835 /* Simple but imcomplete way. */
1836 if (i
!= 0 && EQ (obj
, halftail
))
1838 sprintf (buf
, " . #%d", i
/ 2);
1839 strout (buf
, -1, -1, printcharfun
, 0);
1845 /* With the print-circle feature. */
1849 for (i
= 0; i
< print_number_index
; i
++)
1850 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
),
1853 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1855 strout (" . ", 3, 3, printcharfun
, 0);
1856 print_object (obj
, printcharfun
, escapeflag
);
1860 sprintf (buf
, " . #%d#", i
+ 1);
1861 strout (buf
, -1, -1, printcharfun
, 0);
1871 if (print_length
&& i
> print_length
)
1873 strout ("...", 3, 3, printcharfun
, 0);
1877 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1881 halftail
= XCDR (halftail
);
1885 /* OBJ non-nil here means it's the end of a dotted list. */
1888 strout (" . ", 3, 3, printcharfun
, 0);
1889 print_object (obj
, printcharfun
, escapeflag
);
1897 case Lisp_Vectorlike
:
1902 strout ("#<process ", -1, -1, printcharfun
, 0);
1903 print_string (XPROCESS (obj
)->name
, printcharfun
);
1907 print_string (XPROCESS (obj
)->name
, printcharfun
);
1909 else if (BOOL_VECTOR_P (obj
))
1912 register unsigned char c
;
1913 struct gcpro gcpro1
;
1915 = ((XBOOL_VECTOR (obj
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
1916 / BOOL_VECTOR_BITS_PER_CHAR
);
1922 sprintf (buf
, "%ld", (long) XBOOL_VECTOR (obj
)->size
);
1923 strout (buf
, -1, -1, printcharfun
, 0);
1926 /* Don't print more characters than the specified maximum.
1927 Negative values of print-length are invalid. Treat them
1928 like a print-length of nil. */
1929 if (NATNUMP (Vprint_length
)
1930 && XFASTINT (Vprint_length
) < size_in_chars
)
1931 size_in_chars
= XFASTINT (Vprint_length
);
1933 for (i
= 0; i
< size_in_chars
; i
++)
1936 c
= XBOOL_VECTOR (obj
)->data
[i
];
1937 if (! ASCII_BYTE_P (c
))
1939 sprintf (buf
, "\\%03o", c
);
1940 strout (buf
, -1, -1, printcharfun
, 0);
1942 else if (c
== '\n' && print_escape_newlines
)
1947 else if (c
== '\f' && print_escape_newlines
)
1952 else if (c
> '\177')
1954 /* Use octal escapes to avoid encoding issues. */
1956 PRINTCHAR ('0' + ((c
>> 6) & 3));
1957 PRINTCHAR ('0' + ((c
>> 3) & 7));
1958 PRINTCHAR ('0' + (c
& 7));
1962 if (c
== '\"' || c
== '\\')
1971 else if (SUBRP (obj
))
1973 strout ("#<subr ", -1, -1, printcharfun
, 0);
1974 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
, 0);
1977 else if (WINDOWP (obj
))
1979 strout ("#<window ", -1, -1, printcharfun
, 0);
1980 sprintf (buf
, "%ld", (long) XFASTINT (XWINDOW (obj
)->sequence_number
));
1981 strout (buf
, -1, -1, printcharfun
, 0);
1982 if (!NILP (XWINDOW (obj
)->buffer
))
1984 strout (" on ", -1, -1, printcharfun
, 0);
1985 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1989 else if (HASH_TABLE_P (obj
))
1991 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1992 strout ("#<hash-table", -1, -1, printcharfun
, 0);
1993 if (SYMBOLP (h
->test
))
1997 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
, 0);
1999 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
, 0);
2001 sprintf (buf
, "%ld/%ld", (long) XFASTINT (h
->count
),
2002 (long) XVECTOR (h
->next
)->size
);
2003 strout (buf
, -1, -1, printcharfun
, 0);
2005 sprintf (buf
, " 0x%lx", (unsigned long) h
);
2006 strout (buf
, -1, -1, printcharfun
, 0);
2009 else if (BUFFERP (obj
))
2011 if (NILP (XBUFFER (obj
)->name
))
2012 strout ("#<killed buffer>", -1, -1, printcharfun
, 0);
2013 else if (escapeflag
)
2015 strout ("#<buffer ", -1, -1, printcharfun
, 0);
2016 print_string (XBUFFER (obj
)->name
, printcharfun
);
2020 print_string (XBUFFER (obj
)->name
, printcharfun
);
2022 else if (WINDOW_CONFIGURATIONP (obj
))
2024 strout ("#<window-configuration>", -1, -1, printcharfun
, 0);
2026 else if (FRAMEP (obj
))
2028 strout ((FRAME_LIVE_P (XFRAME (obj
))
2029 ? "#<frame " : "#<dead frame "),
2030 -1, -1, printcharfun
, 0);
2031 print_string (XFRAME (obj
)->name
, printcharfun
);
2032 sprintf (buf
, " 0x%lx", (unsigned long) (XFRAME (obj
)));
2033 strout (buf
, -1, -1, printcharfun
, 0);
2038 EMACS_INT size
= XVECTOR (obj
)->size
;
2039 if (COMPILEDP (obj
))
2042 size
&= PSEUDOVECTOR_SIZE_MASK
;
2044 if (CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
))
2046 /* We print a char-table as if it were a vector,
2047 lumping the parent and default slots in with the
2048 character slots. But we add #^ as a prefix. */
2051 if (SUB_CHAR_TABLE_P (obj
))
2053 size
&= PSEUDOVECTOR_SIZE_MASK
;
2055 if (size
& PSEUDOVECTOR_FLAG
)
2061 register Lisp_Object tem
;
2062 int real_size
= size
;
2064 /* Don't print more elements than the specified maximum. */
2065 if (NATNUMP (Vprint_length
)
2066 && XFASTINT (Vprint_length
) < size
)
2067 size
= XFASTINT (Vprint_length
);
2069 for (i
= 0; i
< size
; i
++)
2071 if (i
) PRINTCHAR (' ');
2072 tem
= XVECTOR (obj
)->contents
[i
];
2073 print_object (tem
, printcharfun
, escapeflag
);
2075 if (size
< real_size
)
2076 strout (" ...", 4, 4, printcharfun
, 0);
2083 switch (XMISCTYPE (obj
))
2085 case Lisp_Misc_Marker
:
2086 strout ("#<marker ", -1, -1, printcharfun
, 0);
2087 /* Do you think this is necessary? */
2088 if (XMARKER (obj
)->insertion_type
!= 0)
2089 strout ("(moves after insertion) ", -1, -1, printcharfun
, 0);
2090 if (!(XMARKER (obj
)->buffer
))
2091 strout ("in no buffer", -1, -1, printcharfun
, 0);
2094 sprintf (buf
, "at %d", marker_position (obj
));
2095 strout (buf
, -1, -1, printcharfun
, 0);
2096 strout (" in ", -1, -1, printcharfun
, 0);
2097 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
2102 case Lisp_Misc_Overlay
:
2103 strout ("#<overlay ", -1, -1, printcharfun
, 0);
2104 if (!(XMARKER (OVERLAY_START (obj
))->buffer
))
2105 strout ("in no buffer", -1, -1, printcharfun
, 0);
2108 sprintf (buf
, "from %d to %d in ",
2109 marker_position (OVERLAY_START (obj
)),
2110 marker_position (OVERLAY_END (obj
)));
2111 strout (buf
, -1, -1, printcharfun
, 0);
2112 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
2118 /* Remaining cases shouldn't happen in normal usage, but let's print
2119 them anyway for the benefit of the debugger. */
2120 case Lisp_Misc_Free
:
2121 strout ("#<misc free cell>", -1, -1, printcharfun
, 0);
2124 case Lisp_Misc_Intfwd
:
2125 sprintf (buf
, "#<intfwd to %ld>", (long) *XINTFWD (obj
)->intvar
);
2126 strout (buf
, -1, -1, printcharfun
, 0);
2129 case Lisp_Misc_Boolfwd
:
2130 sprintf (buf
, "#<boolfwd to %s>",
2131 (*XBOOLFWD (obj
)->boolvar
? "t" : "nil"));
2132 strout (buf
, -1, -1, printcharfun
, 0);
2135 case Lisp_Misc_Objfwd
:
2136 strout ("#<objfwd to ", -1, -1, printcharfun
, 0);
2137 print_object (*XOBJFWD (obj
)->objvar
, printcharfun
, escapeflag
);
2141 case Lisp_Misc_Buffer_Objfwd
:
2142 strout ("#<buffer_objfwd to ", -1, -1, printcharfun
, 0);
2143 print_object (PER_BUFFER_VALUE (current_buffer
,
2144 XBUFFER_OBJFWD (obj
)->offset
),
2145 printcharfun
, escapeflag
);
2149 case Lisp_Misc_Kboard_Objfwd
:
2150 strout ("#<kboard_objfwd to ", -1, -1, printcharfun
, 0);
2151 print_object (*(Lisp_Object
*)((char *) current_kboard
2152 + XKBOARD_OBJFWD (obj
)->offset
),
2153 printcharfun
, escapeflag
);
2157 case Lisp_Misc_Buffer_Local_Value
:
2158 strout ("#<buffer_local_value ", -1, -1, printcharfun
, 0);
2159 goto do_buffer_local
;
2160 case Lisp_Misc_Some_Buffer_Local_Value
:
2161 strout ("#<some_buffer_local_value ", -1, -1, printcharfun
, 0);
2163 strout ("[realvalue] ", -1, -1, printcharfun
, 0);
2164 print_object (XBUFFER_LOCAL_VALUE (obj
)->realvalue
,
2165 printcharfun
, escapeflag
);
2166 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_buffer
)
2167 strout ("[local in buffer] ", -1, -1, printcharfun
, 0);
2169 strout ("[buffer] ", -1, -1, printcharfun
, 0);
2170 print_object (XBUFFER_LOCAL_VALUE (obj
)->buffer
,
2171 printcharfun
, escapeflag
);
2172 if (XBUFFER_LOCAL_VALUE (obj
)->check_frame
)
2174 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_frame
)
2175 strout ("[local in frame] ", -1, -1, printcharfun
, 0);
2177 strout ("[frame] ", -1, -1, printcharfun
, 0);
2178 print_object (XBUFFER_LOCAL_VALUE (obj
)->frame
,
2179 printcharfun
, escapeflag
);
2181 strout ("[alist-elt] ", -1, -1, printcharfun
, 0);
2182 print_object (XCAR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
2183 printcharfun
, escapeflag
);
2184 strout ("[default-value] ", -1, -1, printcharfun
, 0);
2185 print_object (XCDR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
2186 printcharfun
, escapeflag
);
2190 case Lisp_Misc_Save_Value
:
2191 strout ("#<save_value ", -1, -1, printcharfun
, 0);
2192 sprintf(buf
, "ptr=0x%08lx int=%d",
2193 (unsigned long) XSAVE_VALUE (obj
)->pointer
,
2194 XSAVE_VALUE (obj
)->integer
);
2195 strout (buf
, -1, -1, printcharfun
, 0);
2207 /* We're in trouble if this happens!
2208 Probably should just abort () */
2209 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
, 0);
2211 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2212 else if (VECTORLIKEP (obj
))
2213 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
2215 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2216 strout (buf
, -1, -1, printcharfun
, 0);
2217 strout (" Save your buffers immediately and please report this bug>",
2218 -1, -1, printcharfun
, 0);
2226 /* Print a description of INTERVAL using PRINTCHARFUN.
2227 This is part of printing a string that has text properties. */
2230 print_interval (interval
, printcharfun
)
2232 Lisp_Object printcharfun
;
2234 if (NILP (interval
->plist
))
2237 print_object (make_number (interval
->position
), printcharfun
, 1);
2239 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2242 print_object (interval
->plist
, printcharfun
, 1);
2249 Qtemp_buffer_setup_hook
= intern ("temp-buffer-setup-hook");
2250 staticpro (&Qtemp_buffer_setup_hook
);
2252 DEFVAR_LISP ("standard-output", &Vstandard_output
,
2253 doc
: /* Output stream `print' uses by default for outputting a character.
2254 This may be any function of one argument.
2255 It may also be a buffer (output is inserted before point)
2256 or a marker (output is inserted and the marker is advanced)
2257 or the symbol t (output appears in the echo area). */);
2258 Vstandard_output
= Qt
;
2259 Qstandard_output
= intern ("standard-output");
2260 staticpro (&Qstandard_output
);
2262 DEFVAR_LISP ("float-output-format", &Vfloat_output_format
,
2263 doc
: /* The format descriptor string used to print floats.
2264 This is a %-spec like those accepted by `printf' in C,
2265 but with some restrictions. It must start with the two characters `%.'.
2266 After that comes an integer precision specification,
2267 and then a letter which controls the format.
2268 The letters allowed are `e', `f' and `g'.
2269 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2270 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2271 Use `g' to choose the shorter of those two formats for the number at hand.
2272 The precision in any of these cases is the number of digits following
2273 the decimal point. With `f', a precision of 0 means to omit the
2274 decimal point. 0 is not allowed with `e' or `g'.
2276 A value of nil means to use the shortest notation
2277 that represents the number without losing information. */);
2278 Vfloat_output_format
= Qnil
;
2279 Qfloat_output_format
= intern ("float-output-format");
2280 staticpro (&Qfloat_output_format
);
2282 DEFVAR_LISP ("print-length", &Vprint_length
,
2283 doc
: /* Maximum length of list to print before abbreviating.
2284 A value of nil means no limit. See also `eval-expression-print-length'. */);
2285 Vprint_length
= Qnil
;
2287 DEFVAR_LISP ("print-level", &Vprint_level
,
2288 doc
: /* Maximum depth of list nesting to print before abbreviating.
2289 A value of nil means no limit. See also `eval-expression-print-level'. */);
2290 Vprint_level
= Qnil
;
2292 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines
,
2293 doc
: /* Non-nil means print newlines in strings as `\\n'.
2294 Also print formfeeds as `\\f'. */);
2295 print_escape_newlines
= 0;
2297 DEFVAR_BOOL ("print-escape-nonascii", &print_escape_nonascii
,
2298 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2299 \(OOO is the octal representation of the character code.)
2300 Only single-byte characters are affected, and only in `prin1'.
2301 When the output goes in a multibyte buffer, this feature is
2302 enabled regardless of the value of the variable. */);
2303 print_escape_nonascii
= 0;
2305 DEFVAR_BOOL ("print-escape-multibyte", &print_escape_multibyte
,
2306 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2307 \(XXXX is the hex representation of the character code.)
2308 This affects only `prin1'. */);
2309 print_escape_multibyte
= 0;
2311 DEFVAR_BOOL ("print-quoted", &print_quoted
,
2312 doc
: /* Non-nil means print quoted forms with reader syntax.
2313 I.e., (quote foo) prints as 'foo, (function foo) as #'foo, and backquoted
2314 forms print as in the new syntax. */);
2317 DEFVAR_LISP ("print-gensym", &Vprint_gensym
,
2318 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2319 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2320 When the uninterned symbol appears within a recursive data structure,
2321 and the symbol appears more than once, in addition use the #N# and #N=
2322 constructs as needed, so that multiple references to the same symbol are
2323 shared once again when the text is read back. */);
2324 Vprint_gensym
= Qnil
;
2326 DEFVAR_LISP ("print-circle", &Vprint_circle
,
2327 doc
: /* *Non-nil means print recursive structures using #N= and #N# syntax.
2328 If nil, printing proceeds recursively and may lead to
2329 `max-lisp-eval-depth' being exceeded or an error may occur:
2330 \"Apparently circular structure being printed.\" Also see
2331 `print-length' and `print-level'.
2332 If non-nil, shared substructures anywhere in the structure are printed
2333 with `#N=' before the first occurrence (in the order of the print
2334 representation) and `#N#' in place of each subsequent occurrence,
2335 where N is a positive decimal integer. */);
2336 Vprint_circle
= Qnil
;
2338 DEFVAR_LISP ("print-continuous-numbering", &Vprint_continuous_numbering
,
2339 doc
: /* *Non-nil means number continuously across print calls.
2340 This affects the numbers printed for #N= labels and #M# references.
2341 See also `print-circle', `print-gensym', and `print-number-table'.
2342 This variable should not be set with `setq'; bind it with a `let' instead. */);
2343 Vprint_continuous_numbering
= Qnil
;
2345 DEFVAR_LISP ("print-number-table", &Vprint_number_table
,
2346 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2347 The Lisp printer uses this vector to detect Lisp objects referenced more
2350 When you bind `print-continuous-numbering' to t, you should probably
2351 also bind `print-number-table' to nil. This ensures that the value of
2352 `print-number-table' can be garbage-collected once the printing is
2353 done. If all elements of `print-number-table' are nil, it means that
2354 the printing done so far has not found any shared structure or objects
2355 that need to be recorded in the table. */);
2356 Vprint_number_table
= Qnil
;
2358 DEFVAR_LISP ("print-charset-text-property", &Vprint_charset_text_property
,
2359 doc
: /* A flag to control printing of `charset' text property on printing a string.
2360 The value must be nil, t, or `default'.
2362 If the value is nil, don't print the text property `charset'.
2364 If the value is t, always print the text property `charset'.
2366 If the value is `default', print the text property `charset' only when
2367 the value is different from what is guessed in the current charset
2369 Vprint_charset_text_property
= Qdefault
;
2371 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2372 staticpro (&Vprin1_to_string_buffer
);
2375 defsubr (&Sprin1_to_string
);
2376 defsubr (&Serror_message_string
);
2380 defsubr (&Swrite_char
);
2381 defsubr (&Sexternal_debugging_output
);
2382 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2383 defsubr (&Sredirect_debugging_output
);
2386 Qexternal_debugging_output
= intern ("external-debugging-output");
2387 staticpro (&Qexternal_debugging_output
);
2389 Qprint_escape_newlines
= intern ("print-escape-newlines");
2390 staticpro (&Qprint_escape_newlines
);
2392 Qprint_escape_multibyte
= intern ("print-escape-multibyte");
2393 staticpro (&Qprint_escape_multibyte
);
2395 Qprint_escape_nonascii
= intern ("print-escape-nonascii");
2396 staticpro (&Qprint_escape_nonascii
);
2398 print_prune_charset_plist
= Qnil
;
2399 staticpro (&print_prune_charset_plist
);
2401 defsubr (&Swith_output_to_temp_buffer
);
2404 /* arch-tag: bc797170-94ae-41de-86e3-75e20f8f7a39
2405 (do not change this comment) */