1 /* Lisp object printing and output streams.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997,
3 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 Boston, MA 02110-1301, USA. */
33 #include "dispextern.h"
35 #include "intervals.h"
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 ();
185 /* GDB resets this to zero on W32 to disable OutputDebugString calls. */
186 int print_output_debug_flag
= 1;
189 /* Low level output routines for characters and strings */
191 /* Lisp functions to do output using a stream
192 must have the stream in a variable called printcharfun
193 and must start with PRINTPREPARE, end with PRINTFINISH,
194 and use PRINTDECLARE to declare common variables.
195 Use PRINTCHAR to output one character,
196 or call strout to output a block of characters. */
198 #define PRINTDECLARE \
199 struct buffer *old = current_buffer; \
200 int old_point = -1, start_point = -1; \
201 int old_point_byte = -1, start_point_byte = -1; \
202 int specpdl_count = SPECPDL_INDEX (); \
203 int free_print_buffer = 0; \
204 int multibyte = !NILP (current_buffer->enable_multibyte_characters); \
207 #define PRINTPREPARE \
208 original = printcharfun; \
209 if (NILP (printcharfun)) printcharfun = Qt; \
210 if (BUFFERP (printcharfun)) \
212 if (XBUFFER (printcharfun) != current_buffer) \
213 Fset_buffer (printcharfun); \
214 printcharfun = Qnil; \
216 if (MARKERP (printcharfun)) \
218 EMACS_INT marker_pos; \
219 if (!(XMARKER (printcharfun)->buffer)) \
220 error ("Marker does not point anywhere"); \
221 if (XMARKER (printcharfun)->buffer != current_buffer) \
222 set_buffer_internal (XMARKER (printcharfun)->buffer); \
223 marker_pos = marker_position (printcharfun); \
224 if (marker_pos < BEGV || marker_pos > ZV) \
225 error ("Marker is outside the accessible part of the buffer"); \
227 old_point_byte = PT_BYTE; \
228 SET_PT_BOTH (marker_pos, \
229 marker_byte_position (printcharfun)); \
231 start_point_byte = PT_BYTE; \
232 printcharfun = Qnil; \
234 if (NILP (printcharfun)) \
236 Lisp_Object string; \
237 if (NILP (current_buffer->enable_multibyte_characters) \
238 && ! print_escape_multibyte) \
239 specbind (Qprint_escape_multibyte, Qt); \
240 if (! NILP (current_buffer->enable_multibyte_characters) \
241 && ! print_escape_nonascii) \
242 specbind (Qprint_escape_nonascii, Qt); \
243 if (print_buffer != 0) \
245 string = make_string_from_bytes (print_buffer, \
247 print_buffer_pos_byte); \
248 record_unwind_protect (print_unwind, string); \
252 print_buffer_size = 1000; \
253 print_buffer = (char *) xmalloc (print_buffer_size); \
254 free_print_buffer = 1; \
256 print_buffer_pos = 0; \
257 print_buffer_pos_byte = 0; \
259 if (EQ (printcharfun, Qt) && ! noninteractive) \
260 setup_echo_area_for_printing (multibyte);
262 #define PRINTFINISH \
263 if (NILP (printcharfun)) \
265 if (print_buffer_pos != print_buffer_pos_byte \
266 && NILP (current_buffer->enable_multibyte_characters)) \
268 unsigned char *temp \
269 = (unsigned char *) alloca (print_buffer_pos + 1); \
270 copy_text (print_buffer, temp, print_buffer_pos_byte, \
272 insert_1_both (temp, print_buffer_pos, \
273 print_buffer_pos, 0, 1, 0); \
276 insert_1_both (print_buffer, print_buffer_pos, \
277 print_buffer_pos_byte, 0, 1, 0); \
278 signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
280 if (free_print_buffer) \
282 xfree (print_buffer); \
285 unbind_to (specpdl_count, Qnil); \
286 if (MARKERP (original)) \
287 set_marker_both (original, Qnil, PT, PT_BYTE); \
288 if (old_point >= 0) \
289 SET_PT_BOTH (old_point + (old_point >= start_point \
290 ? PT - start_point : 0), \
291 old_point_byte + (old_point_byte >= start_point_byte \
292 ? PT_BYTE - start_point_byte : 0)); \
293 if (old != current_buffer) \
294 set_buffer_internal (old);
296 #define PRINTCHAR(ch) printchar (ch, printcharfun)
298 /* This is used to restore the saved contents of print_buffer
299 when there is a recursive call to print. */
302 print_unwind (saved_text
)
303 Lisp_Object saved_text
;
305 bcopy (SDATA (saved_text
), print_buffer
, SCHARS (saved_text
));
310 /* Print character CH using method FUN. FUN nil means print to
311 print_buffer. FUN t means print to echo area or stdout if
312 non-interactive. If FUN is neither nil nor t, call FUN with CH as
320 #ifdef MAX_PRINT_CHARS
323 #endif /* MAX_PRINT_CHARS */
325 if (!NILP (fun
) && !EQ (fun
, Qt
))
326 call1 (fun
, make_number (ch
));
329 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
330 int len
= CHAR_STRING (ch
, str
);
336 if (print_buffer_pos_byte
+ len
>= print_buffer_size
)
337 print_buffer
= (char *) xrealloc (print_buffer
,
338 print_buffer_size
*= 2);
339 bcopy (str
, print_buffer
+ print_buffer_pos_byte
, len
);
340 print_buffer_pos
+= 1;
341 print_buffer_pos_byte
+= len
;
343 else if (noninteractive
)
345 fwrite (str
, 1, len
, stdout
);
346 noninteractive_need_newline
= 1;
351 = !NILP (current_buffer
->enable_multibyte_characters
);
353 setup_echo_area_for_printing (multibyte_p
);
355 message_dolog (str
, len
, 0, multibyte_p
);
361 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
362 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
363 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
364 print_buffer. PRINTCHARFUN t means output to the echo area or to
365 stdout if non-interactive. If neither nil nor t, call Lisp
366 function PRINTCHARFUN for each character printed. MULTIBYTE
367 non-zero means PTR contains multibyte characters. */
370 strout (ptr
, size
, size_byte
, printcharfun
, multibyte
)
373 Lisp_Object printcharfun
;
377 size_byte
= size
= strlen (ptr
);
379 if (NILP (printcharfun
))
381 if (print_buffer_pos_byte
+ size_byte
> print_buffer_size
)
383 print_buffer_size
= print_buffer_size
* 2 + size_byte
;
384 print_buffer
= (char *) xrealloc (print_buffer
,
387 bcopy (ptr
, print_buffer
+ print_buffer_pos_byte
, size_byte
);
388 print_buffer_pos
+= size
;
389 print_buffer_pos_byte
+= size_byte
;
391 #ifdef MAX_PRINT_CHARS
394 #endif /* MAX_PRINT_CHARS */
396 else if (noninteractive
&& EQ (printcharfun
, Qt
))
398 fwrite (ptr
, 1, size_byte
, stdout
);
399 noninteractive_need_newline
= 1;
401 else if (EQ (printcharfun
, Qt
))
403 /* Output to echo area. We're trying to avoid a little overhead
404 here, that's the reason we don't call printchar to do the
408 = !NILP (current_buffer
->enable_multibyte_characters
);
410 setup_echo_area_for_printing (multibyte_p
);
411 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
413 if (size
== size_byte
)
415 for (i
= 0; i
< size
; ++i
)
416 insert_char ((unsigned char )*ptr
++);
421 for (i
= 0; i
< size_byte
; i
+= len
)
423 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size_byte
- i
, len
);
428 #ifdef MAX_PRINT_CHARS
431 #endif /* MAX_PRINT_CHARS */
435 /* PRINTCHARFUN is a Lisp function. */
438 if (size
== size_byte
)
440 while (i
< size_byte
)
448 while (i
< size_byte
)
450 /* Here, we must convert each multi-byte form to the
451 corresponding character code before handing it to
454 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size_byte
- i
, len
);
462 /* Print the contents of a string STRING using PRINTCHARFUN.
463 It isn't safe to use strout in many cases,
464 because printing one char can relocate. */
467 print_string (string
, printcharfun
)
469 Lisp_Object printcharfun
;
471 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
475 if (STRING_MULTIBYTE (string
))
476 chars
= SCHARS (string
);
477 else if (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
,
525 if (!CHAR_VALID_P (ch
, 0))
527 ch
= SREF (string
, i
);
537 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
538 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
539 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
540 (character
, printcharfun
)
541 Lisp_Object character
, printcharfun
;
545 if (NILP (printcharfun
))
546 printcharfun
= Vstandard_output
;
547 CHECK_NUMBER (character
);
549 PRINTCHAR (XINT (character
));
554 /* Used from outside of print.c to print a block of SIZE
555 single-byte chars at DATA on the default output stream.
556 Do not use this on the contents of a Lisp string. */
559 write_string (data
, size
)
564 Lisp_Object printcharfun
;
566 printcharfun
= Vstandard_output
;
569 strout (data
, size
, size
, printcharfun
, 0);
573 /* Used from outside of print.c to print a block of SIZE
574 single-byte chars at DATA on a specified stream PRINTCHARFUN.
575 Do not use this on the contents of a Lisp string. */
578 write_string_1 (data
, size
, printcharfun
)
581 Lisp_Object printcharfun
;
586 strout (data
, size
, size
, printcharfun
, 0);
592 temp_output_buffer_setup (bufname
)
595 int count
= SPECPDL_INDEX ();
596 register struct buffer
*old
= current_buffer
;
597 register Lisp_Object buf
;
599 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
601 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
603 Fkill_all_local_variables ();
604 delete_all_overlays (current_buffer
);
605 current_buffer
->directory
= old
->directory
;
606 current_buffer
->read_only
= Qnil
;
607 current_buffer
->filename
= Qnil
;
608 current_buffer
->undo_list
= Qt
;
609 eassert (current_buffer
->overlays_before
== NULL
);
610 eassert (current_buffer
->overlays_after
== NULL
);
611 current_buffer
->enable_multibyte_characters
612 = buffer_defaults
.enable_multibyte_characters
;
613 specbind (Qinhibit_read_only
, Qt
);
614 specbind (Qinhibit_modification_hooks
, Qt
);
616 XSETBUFFER (buf
, current_buffer
);
618 Frun_hooks (1, &Qtemp_buffer_setup_hook
);
620 unbind_to (count
, Qnil
);
622 specbind (Qstandard_output
, buf
);
626 internal_with_output_to_temp_buffer (bufname
, function
, args
)
628 Lisp_Object (*function
) P_ ((Lisp_Object
));
631 int count
= SPECPDL_INDEX ();
632 Lisp_Object buf
, val
;
636 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
637 temp_output_buffer_setup (bufname
);
638 buf
= Vstandard_output
;
641 val
= (*function
) (args
);
644 temp_output_buffer_show (buf
);
647 return unbind_to (count
, val
);
650 DEFUN ("with-output-to-temp-buffer",
651 Fwith_output_to_temp_buffer
, Swith_output_to_temp_buffer
,
653 doc
: /* Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
654 The buffer is cleared out initially, and marked as unmodified when done.
655 All output done by BODY is inserted in that buffer by default.
656 The buffer is displayed in another window, but not selected.
657 The value of the last form in BODY is returned.
658 If BODY does not finish normally, the buffer BUFNAME is not displayed.
660 The hook `temp-buffer-setup-hook' is run before BODY,
661 with the buffer BUFNAME temporarily current.
662 The hook `temp-buffer-show-hook' is run after the buffer is displayed,
663 with the buffer temporarily current, and the window that was used
664 to display it temporarily selected.
666 If variable `temp-buffer-show-function' is non-nil, call it at the end
667 to get the buffer displayed instead of just displaying the non-selected
668 buffer and calling the hook. It gets one argument, the buffer to display.
670 usage: (with-output-to-temp-buffer BUFNAME BODY ...) */)
676 int count
= SPECPDL_INDEX ();
677 Lisp_Object buf
, val
;
680 name
= Feval (Fcar (args
));
682 temp_output_buffer_setup (SDATA (name
));
683 buf
= Vstandard_output
;
686 val
= Fprogn (XCDR (args
));
689 temp_output_buffer_show (buf
);
692 return unbind_to (count
, val
);
696 static void print ();
697 static void print_preprocess ();
698 static void print_preprocess_string ();
699 static void print_object ();
701 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
702 doc
: /* Output a newline to stream PRINTCHARFUN.
703 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
705 Lisp_Object printcharfun
;
709 if (NILP (printcharfun
))
710 printcharfun
= Vstandard_output
;
717 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
718 doc
: /* Output the printed representation of OBJECT, any Lisp object.
719 Quoting characters are printed when needed to make output that `read'
720 can handle, whenever this is possible. For complex objects, the behavior
721 is controlled by `print-level' and `print-length', which see.
723 OBJECT is any of the Lisp data types: a number, a string, a symbol,
724 a list, a buffer, a window, a frame, etc.
726 A printed representation of an object is text which describes that object.
728 Optional argument PRINTCHARFUN is the output stream, which can be one
731 - a buffer, in which case output is inserted into that buffer at point;
732 - a marker, in which case output is inserted at marker's position;
733 - a function, in which case that function is called once for each
734 character of OBJECT's printed representation;
735 - a symbol, in which case that symbol's function definition is called; or
736 - t, in which case the output is displayed in the echo area.
738 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
740 (object
, printcharfun
)
741 Lisp_Object object
, printcharfun
;
745 #ifdef MAX_PRINT_CHARS
747 #endif /* MAX_PRINT_CHARS */
748 if (NILP (printcharfun
))
749 printcharfun
= Vstandard_output
;
751 print (object
, printcharfun
, 1);
756 /* a buffer which is used to hold output being built by prin1-to-string */
757 Lisp_Object Vprin1_to_string_buffer
;
759 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
760 doc
: /* Return a string containing the printed representation of OBJECT.
761 OBJECT can be any Lisp object. This function outputs quoting characters
762 when necessary to make output that `read' can handle, whenever possible,
763 unless the optional second argument NOESCAPE is non-nil. For complex objects,
764 the behavior is controlled by `print-level' and `print-length', which see.
766 OBJECT is any of the Lisp data types: a number, a string, a symbol,
767 a list, a buffer, a window, a frame, etc.
769 A printed representation of an object is text which describes that object. */)
771 Lisp_Object object
, noescape
;
773 Lisp_Object printcharfun
;
774 /* struct gcpro gcpro1, gcpro2; */
775 Lisp_Object save_deactivate_mark
;
776 int count
= specpdl_ptr
- specpdl
;
777 struct buffer
*previous
;
779 specbind (Qinhibit_modification_hooks
, Qt
);
784 /* Save and restore this--we are altering a buffer
785 but we don't want to deactivate the mark just for that.
786 No need for specbind, since errors deactivate the mark. */
787 save_deactivate_mark
= Vdeactivate_mark
;
788 /* GCPRO2 (object, save_deactivate_mark); */
791 printcharfun
= Vprin1_to_string_buffer
;
793 print (object
, printcharfun
, NILP (noescape
));
794 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
798 previous
= current_buffer
;
799 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
800 object
= Fbuffer_string ();
801 if (SBYTES (object
) == SCHARS (object
))
802 STRING_SET_UNIBYTE (object
);
804 /* Note that this won't make prepare_to_modify_buffer call
805 ask-user-about-supersession-threat because this buffer
806 does not visit a file. */
808 set_buffer_internal (previous
);
810 Vdeactivate_mark
= save_deactivate_mark
;
814 return unbind_to (count
, object
);
817 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
818 doc
: /* Output the printed representation of OBJECT, any Lisp object.
819 No quoting characters are used; no delimiters are printed around
820 the contents of strings.
822 OBJECT is any of the Lisp data types: a number, a string, a symbol,
823 a list, a buffer, a window, a frame, etc.
825 A printed representation of an object is text which describes that object.
827 Optional argument PRINTCHARFUN is the output stream, which can be one
830 - a buffer, in which case output is inserted into that buffer at point;
831 - a marker, in which case output is inserted at marker's position;
832 - a function, in which case that function is called once for each
833 character of OBJECT's printed representation;
834 - a symbol, in which case that symbol's function definition is called; or
835 - t, in which case the output is displayed in the echo area.
837 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
839 (object
, printcharfun
)
840 Lisp_Object object
, printcharfun
;
844 if (NILP (printcharfun
))
845 printcharfun
= Vstandard_output
;
847 print (object
, printcharfun
, 0);
852 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
853 doc
: /* Output the printed representation of OBJECT, with newlines around it.
854 Quoting characters are printed when needed to make output that `read'
855 can handle, whenever this is possible. For complex objects, the behavior
856 is controlled by `print-level' and `print-length', which see.
858 OBJECT is any of the Lisp data types: a number, a string, a symbol,
859 a list, a buffer, a window, a frame, etc.
861 A printed representation of an object is text which describes that object.
863 Optional argument PRINTCHARFUN is the output stream, which can be one
866 - a buffer, in which case output is inserted into that buffer at point;
867 - a marker, in which case output is inserted at marker's position;
868 - a function, in which case that function is called once for each
869 character of OBJECT's printed representation;
870 - a symbol, in which case that symbol's function definition is called; or
871 - t, in which case the output is displayed in the echo area.
873 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
875 (object
, printcharfun
)
876 Lisp_Object object
, printcharfun
;
881 #ifdef MAX_PRINT_CHARS
883 max_print
= MAX_PRINT_CHARS
;
884 #endif /* MAX_PRINT_CHARS */
885 if (NILP (printcharfun
))
886 printcharfun
= Vstandard_output
;
890 print (object
, printcharfun
, 1);
893 #ifdef MAX_PRINT_CHARS
896 #endif /* MAX_PRINT_CHARS */
901 /* The subroutine object for external-debugging-output is kept here
902 for the convenience of the debugger. */
903 Lisp_Object Qexternal_debugging_output
;
905 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
906 doc
: /* Write CHARACTER to stderr.
907 You can call print while debugging emacs, and pass it this function
908 to make it write to the debugging output. */)
910 Lisp_Object character
;
912 CHECK_NUMBER (character
);
913 putc (XINT (character
), stderr
);
916 /* Send the output to a debugger (nothing happens if there isn't one). */
917 if (print_output_debug_flag
)
919 char buf
[2] = {(char) XINT (character
), '\0'};
920 OutputDebugString (buf
);
928 #if defined(GNU_LINUX)
930 /* This functionality is not vitally important in general, so we rely on
931 non-portable ability to use stderr as lvalue. */
933 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
935 FILE *initial_stderr_stream
= NULL
;
937 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
939 "FDebug output file: \nP",
940 doc
: /* Redirect debugging output (stderr stream) to file FILE.
941 If FILE is nil, reset target to the initial stderr stream.
942 Optional arg APPEND non-nil (interactively, with prefix arg) means
943 append to existing target file. */)
945 Lisp_Object file
, append
;
947 if (initial_stderr_stream
!= NULL
)
949 stderr
= initial_stderr_stream
;
950 initial_stderr_stream
= NULL
;
954 file
= Fexpand_file_name (file
, Qnil
);
955 initial_stderr_stream
= stderr
;
956 stderr
= fopen(SDATA (file
), NILP (append
) ? "w" : "a");
959 stderr
= initial_stderr_stream
;
960 initial_stderr_stream
= NULL
;
961 report_file_error ("Cannot open debugging output stream",
967 #endif /* GNU_LINUX */
970 /* This is the interface for debugging printing. */
976 Fprin1 (arg
, Qexternal_debugging_output
);
977 fprintf (stderr
, "\r\n");
981 safe_debug_print (arg
)
984 int valid
= valid_lisp_object_p (arg
);
989 fprintf (stderr
, "#<%s_LISP_OBJECT 0x%08lx>\r\n",
990 !valid
? "INVALID" : "SOME",
994 (unsigned long) arg
.i
1000 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
1002 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
1003 See Info anchor `(elisp)Definition of signal' for some details on how this
1004 error message is constructed. */)
1008 struct buffer
*old
= current_buffer
;
1010 struct gcpro gcpro1
;
1012 /* If OBJ is (error STRING), just return STRING.
1013 That is not only faster, it also avoids the need to allocate
1014 space here when the error is due to memory full. */
1015 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
1016 && CONSP (XCDR (obj
))
1017 && STRINGP (XCAR (XCDR (obj
)))
1018 && NILP (XCDR (XCDR (obj
))))
1019 return XCAR (XCDR (obj
));
1021 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
1023 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
1024 value
= Fbuffer_string ();
1028 set_buffer_internal (old
);
1034 /* Print an error message for the error DATA onto Lisp output stream
1035 STREAM (suitable for the print functions).
1036 CONTEXT is a C string describing the context of the error.
1037 CALLER is the Lisp function inside which the error was signaled. */
1040 print_error_message (data
, stream
, context
, caller
)
1041 Lisp_Object data
, stream
;
1045 Lisp_Object errname
, errmsg
, file_error
, tail
;
1046 struct gcpro gcpro1
;
1050 write_string_1 (context
, -1, stream
);
1052 /* If we know from where the error was signaled, show it in
1054 if (!NILP (caller
) && SYMBOLP (caller
))
1056 Lisp_Object cname
= SYMBOL_NAME (caller
);
1057 char *name
= alloca (SBYTES (cname
));
1058 bcopy (SDATA (cname
), name
, SBYTES (cname
));
1059 message_dolog (name
, SBYTES (cname
), 0, 0);
1060 message_dolog (": ", 2, 0, 0);
1063 errname
= Fcar (data
);
1065 if (EQ (errname
, Qerror
))
1070 errmsg
= Fcar (data
);
1075 Lisp_Object error_conditions
;
1076 errmsg
= Fget (errname
, Qerror_message
);
1077 error_conditions
= Fget (errname
, Qerror_conditions
);
1078 file_error
= Fmemq (Qfile_error
, error_conditions
);
1081 /* Print an error message including the data items. */
1083 tail
= Fcdr_safe (data
);
1086 /* For file-error, make error message by concatenating
1087 all the data items. They are all strings. */
1088 if (!NILP (file_error
) && CONSP (tail
))
1089 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
1091 if (STRINGP (errmsg
))
1092 Fprinc (errmsg
, stream
);
1094 write_string_1 ("peculiar error", -1, stream
);
1096 for (i
= 0; CONSP (tail
); tail
= XCDR (tail
), i
++)
1100 write_string_1 (i
? ", " : ": ", 2, stream
);
1102 if (!NILP (file_error
) || EQ (errname
, Qend_of_file
))
1103 Fprinc (obj
, stream
);
1105 Fprin1 (obj
, stream
);
1114 * The buffer should be at least as large as the max string size of the
1115 * largest float, printed in the biggest notation. This is undoubtedly
1116 * 20d float_output_format, with the negative of the C-constant "HUGE"
1119 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
1121 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
1122 * case of -1e307 in 20d float_output_format. What is one to do (short of
1123 * re-writing _doprnt to be more sane)?
1128 float_to_string (buf
, data
)
1135 /* Check for plus infinity in a way that won't lose
1136 if there is no plus infinity. */
1137 if (data
== data
/ 2 && data
> 1.0)
1139 strcpy (buf
, "1.0e+INF");
1142 /* Likewise for minus infinity. */
1143 if (data
== data
/ 2 && data
< -1.0)
1145 strcpy (buf
, "-1.0e+INF");
1148 /* Check for NaN in a way that won't fail if there are no NaNs. */
1149 if (! (data
* 0.0 >= 0.0))
1151 /* Prepend "-" if the NaN's sign bit is negative.
1152 The sign bit of a double is the bit that is 1 in -0.0. */
1154 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
1156 u_minus_zero
.d
= - 0.0;
1157 for (i
= 0; i
< sizeof (double); i
++)
1158 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
1164 strcpy (buf
, "0.0e+NaN");
1168 if (NILP (Vfloat_output_format
)
1169 || !STRINGP (Vfloat_output_format
))
1172 /* Generate the fewest number of digits that represent the
1173 floating point value without losing information.
1174 The following method is simple but a bit slow.
1175 For ideas about speeding things up, please see:
1177 Guy L Steele Jr & Jon L White, How to print floating-point numbers
1178 accurately. SIGPLAN notices 25, 6 (June 1990), 112-126.
1180 Robert G Burger & R Kent Dybvig, Printing floating point numbers
1181 quickly and accurately, SIGPLAN notices 31, 5 (May 1996), 108-116. */
1183 width
= fabs (data
) < DBL_MIN
? 1 : DBL_DIG
;
1185 sprintf (buf
, "%.*g", width
, data
);
1186 while (width
++ < DOUBLE_DIGITS_BOUND
&& atof (buf
) != data
);
1188 else /* oink oink */
1190 /* Check that the spec we have is fully valid.
1191 This means not only valid for printf,
1192 but meant for floats, and reasonable. */
1193 cp
= SDATA (Vfloat_output_format
);
1202 /* Check the width specification. */
1204 if ('0' <= *cp
&& *cp
<= '9')
1208 width
= (width
* 10) + (*cp
++ - '0');
1209 while (*cp
>= '0' && *cp
<= '9');
1211 /* A precision of zero is valid only for %f. */
1213 || (width
== 0 && *cp
!= 'f'))
1217 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1223 sprintf (buf
, SDATA (Vfloat_output_format
), data
);
1226 /* Make sure there is a decimal point with digit after, or an
1227 exponent, so that the value is readable as a float. But don't do
1228 this with "%.0f"; it's valid for that not to produce a decimal
1229 point. Note that width can be 0 only for %.0f. */
1232 for (cp
= buf
; *cp
; cp
++)
1233 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1236 if (*cp
== '.' && cp
[1] == 0)
1253 print (obj
, printcharfun
, escapeflag
)
1255 register Lisp_Object printcharfun
;
1258 old_backquote_output
= 0;
1260 /* Reset print_number_index and Vprint_number_table only when
1261 the variable Vprint_continuous_numbering is nil. Otherwise,
1262 the values of these variables will be kept between several
1264 if (NILP (Vprint_continuous_numbering
))
1266 print_number_index
= 0;
1267 Vprint_number_table
= Qnil
;
1270 /* Construct Vprint_number_table for print-gensym and print-circle. */
1271 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1273 int i
, start
, index
;
1274 start
= index
= print_number_index
;
1275 /* Construct Vprint_number_table.
1276 This increments print_number_index for the objects added. */
1278 print_preprocess (obj
);
1280 /* Remove unnecessary objects, which appear only once in OBJ;
1281 that is, whose status is Qnil. Compactify the necessary objects. */
1282 for (i
= start
; i
< print_number_index
; i
++)
1283 if (!NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1285 PRINT_NUMBER_OBJECT (Vprint_number_table
, index
)
1286 = PRINT_NUMBER_OBJECT (Vprint_number_table
, i
);
1290 /* Clear out objects outside the active part of the table. */
1291 for (i
= index
; i
< print_number_index
; i
++)
1292 PRINT_NUMBER_OBJECT (Vprint_number_table
, i
) = Qnil
;
1294 /* Reset the status field for the next print step. Now this
1295 field means whether the object has already been printed. */
1296 for (i
= start
; i
< print_number_index
; i
++)
1297 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qnil
;
1299 print_number_index
= index
;
1303 print_object (obj
, printcharfun
, escapeflag
);
1306 /* Construct Vprint_number_table according to the structure of OBJ.
1307 OBJ itself and all its elements will be added to Vprint_number_table
1308 recursively if it is a list, vector, compiled function, char-table,
1309 string (its text properties will be traced), or a symbol that has
1310 no obarray (this is for the print-gensym feature).
1311 The status fields of Vprint_number_table mean whether each object appears
1312 more than once in OBJ: Qnil at the first time, and Qt after that . */
1314 print_preprocess (obj
)
1320 Lisp_Object halftail
;
1322 /* Give up if we go so deep that print_object will get an error. */
1323 /* See similar code in print_object. */
1324 if (print_depth
>= PRINT_CIRCLE
)
1325 error ("Apparently circular structure being printed");
1327 /* Avoid infinite recursion for circular nested structure
1328 in the case where Vprint_circle is nil. */
1329 if (NILP (Vprint_circle
))
1331 for (i
= 0; i
< print_depth
; i
++)
1332 if (EQ (obj
, being_printed
[i
]))
1334 being_printed
[print_depth
] = obj
;
1341 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1342 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
)
1343 || (! NILP (Vprint_gensym
)
1345 && !SYMBOL_INTERNED_P (obj
)))
1347 /* In case print-circle is nil and print-gensym is t,
1348 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1349 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1351 for (i
= 0; i
< print_number_index
; i
++)
1352 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
), obj
))
1354 /* OBJ appears more than once. Let's remember that. */
1355 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1360 /* OBJ is not yet recorded. Let's add to the table. */
1361 if (print_number_index
== 0)
1363 /* Initialize the table. */
1364 Vprint_number_table
= Fmake_vector (make_number (40), Qnil
);
1366 else if (XVECTOR (Vprint_number_table
)->size
== print_number_index
* 2)
1368 /* Reallocate the table. */
1369 int i
= print_number_index
* 4;
1370 Lisp_Object old_table
= Vprint_number_table
;
1371 Vprint_number_table
= Fmake_vector (make_number (i
), Qnil
);
1372 for (i
= 0; i
< print_number_index
; i
++)
1374 PRINT_NUMBER_OBJECT (Vprint_number_table
, i
)
1375 = PRINT_NUMBER_OBJECT (old_table
, i
);
1376 PRINT_NUMBER_STATUS (Vprint_number_table
, i
)
1377 = PRINT_NUMBER_STATUS (old_table
, i
);
1380 PRINT_NUMBER_OBJECT (Vprint_number_table
, print_number_index
) = obj
;
1381 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1382 always print the gensym with a number. This is a special for
1383 the lisp function byte-compile-output-docform. */
1384 if (!NILP (Vprint_continuous_numbering
)
1386 && !SYMBOL_INTERNED_P (obj
))
1387 PRINT_NUMBER_STATUS (Vprint_number_table
, print_number_index
) = Qt
;
1388 print_number_index
++;
1391 switch (XGCTYPE (obj
))
1394 /* A string may have text properties, which can be circular. */
1395 traverse_intervals_noorder (STRING_INTERVALS (obj
),
1396 print_preprocess_string
, Qnil
);
1400 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1401 just as in print_object. */
1402 if (loop_count
&& EQ (obj
, halftail
))
1404 print_preprocess (XCAR (obj
));
1407 if (!(loop_count
& 1))
1408 halftail
= XCDR (halftail
);
1411 case Lisp_Vectorlike
:
1412 size
= XVECTOR (obj
)->size
;
1413 if (size
& PSEUDOVECTOR_FLAG
)
1414 size
&= PSEUDOVECTOR_SIZE_MASK
;
1415 for (i
= 0; i
< size
; i
++)
1416 print_preprocess (XVECTOR (obj
)->contents
[i
]);
1427 print_preprocess_string (interval
, arg
)
1431 print_preprocess (interval
->plist
);
1435 print_object (obj
, printcharfun
, escapeflag
)
1437 register Lisp_Object printcharfun
;
1444 /* Detect circularities and truncate them. */
1445 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1446 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
)
1447 || (! NILP (Vprint_gensym
)
1449 && !SYMBOL_INTERNED_P (obj
)))
1451 if (NILP (Vprint_circle
) && NILP (Vprint_gensym
))
1453 /* Simple but incomplete way. */
1455 for (i
= 0; i
< print_depth
; i
++)
1456 if (EQ (obj
, being_printed
[i
]))
1458 sprintf (buf
, "#%d", i
);
1459 strout (buf
, -1, -1, printcharfun
, 0);
1462 being_printed
[print_depth
] = obj
;
1466 /* With the print-circle feature. */
1468 for (i
= 0; i
< print_number_index
; i
++)
1469 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
), obj
))
1471 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1473 /* Add a prefix #n= if OBJ has not yet been printed;
1474 that is, its status field is nil. */
1475 sprintf (buf
, "#%d=", i
+ 1);
1476 strout (buf
, -1, -1, printcharfun
, 0);
1477 /* OBJ is going to be printed. Set the status to t. */
1478 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1483 /* Just print #n# if OBJ has already been printed. */
1484 sprintf (buf
, "#%d#", i
+ 1);
1485 strout (buf
, -1, -1, printcharfun
, 0);
1494 /* See similar code in print_preprocess. */
1495 if (print_depth
> PRINT_CIRCLE
)
1496 error ("Apparently circular structure being printed");
1497 #ifdef MAX_PRINT_CHARS
1498 if (max_print
&& print_chars
> max_print
)
1503 #endif /* MAX_PRINT_CHARS */
1505 switch (XGCTYPE (obj
))
1508 if (sizeof (int) == sizeof (EMACS_INT
))
1509 sprintf (buf
, "%d", XINT (obj
));
1510 else if (sizeof (long) == sizeof (EMACS_INT
))
1511 sprintf (buf
, "%ld", (long) XINT (obj
));
1514 strout (buf
, -1, -1, printcharfun
, 0);
1519 char pigbuf
[350]; /* see comments in float_to_string */
1521 float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1522 strout (pigbuf
, -1, -1, printcharfun
, 0);
1528 print_string (obj
, printcharfun
);
1531 register int i
, i_byte
;
1532 struct gcpro gcpro1
;
1535 /* 1 means we must ensure that the next character we output
1536 cannot be taken as part of a hex character escape. */
1537 int need_nonhex
= 0;
1538 int multibyte
= STRING_MULTIBYTE (obj
);
1542 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1550 size_byte
= SBYTES (obj
);
1552 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1554 /* Here, we must convert each multi-byte form to the
1555 corresponding character code before handing it to PRINTCHAR. */
1561 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
,
1562 size_byte
- i_byte
, len
);
1563 if (CHAR_VALID_P (c
, 0))
1573 if (c
== '\n' && print_escape_newlines
)
1578 else if (c
== '\f' && print_escape_newlines
)
1584 && ! ASCII_BYTE_P (c
)
1585 && (SINGLE_BYTE_CHAR_P (c
) || print_escape_multibyte
))
1587 /* When multibyte is disabled,
1588 print multibyte string chars using hex escapes.
1589 For a char code that could be in a unibyte string,
1590 when found in a multibyte string, always use a hex escape
1591 so it reads back as multibyte. */
1592 unsigned char outbuf
[50];
1593 sprintf (outbuf
, "\\x%x", c
);
1594 strout (outbuf
, -1, -1, printcharfun
, 0);
1597 else if (! multibyte
1598 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1599 && print_escape_nonascii
)
1601 /* When printing in a multibyte buffer
1602 or when explicitly requested,
1603 print single-byte non-ASCII string chars
1604 using octal escapes. */
1605 unsigned char outbuf
[5];
1606 sprintf (outbuf
, "\\%03o", c
);
1607 strout (outbuf
, -1, -1, printcharfun
, 0);
1611 /* If we just had a hex escape, and this character
1612 could be taken as part of it,
1613 output `\ ' to prevent that. */
1617 if ((c
>= 'a' && c
<= 'f')
1618 || (c
>= 'A' && c
<= 'F')
1619 || (c
>= '0' && c
<= '9'))
1620 strout ("\\ ", -1, -1, printcharfun
, 0);
1623 if (c
== '\"' || c
== '\\')
1630 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1632 traverse_intervals (STRING_INTERVALS (obj
),
1633 0, print_interval
, printcharfun
);
1643 register int confusing
;
1644 register unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1645 register unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1647 int i
, i_byte
, size_byte
;
1650 name
= SYMBOL_NAME (obj
);
1652 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1655 /* If symbol name begins with a digit, and ends with a digit,
1656 and contains nothing but digits and `e', it could be treated
1657 as a number. So set CONFUSING.
1659 Symbols that contain periods could also be taken as numbers,
1660 but periods are always escaped, so we don't have to worry
1662 else if (*p
>= '0' && *p
<= '9'
1663 && end
[-1] >= '0' && end
[-1] <= '9')
1665 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1666 /* Needed for \2e10. */
1669 confusing
= (end
== p
);
1674 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1680 size_byte
= SBYTES (name
);
1682 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1684 /* Here, we must convert each multi-byte form to the
1685 corresponding character code before handing it to PRINTCHAR. */
1686 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1691 if (c
== '\"' || c
== '\\' || c
== '\''
1692 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1693 || c
== ',' || c
=='.' || c
== '`'
1694 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1696 PRINTCHAR ('\\'), confusing
= 0;
1704 /* If deeper than spec'd depth, print placeholder. */
1705 if (INTEGERP (Vprint_level
)
1706 && print_depth
> XINT (Vprint_level
))
1707 strout ("...", -1, -1, printcharfun
, 0);
1708 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1709 && (EQ (XCAR (obj
), Qquote
)))
1712 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1714 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1715 && (EQ (XCAR (obj
), Qfunction
)))
1719 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1721 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1722 && ! old_backquote_output
1723 && ((EQ (XCAR (obj
), Qbackquote
)
1724 || EQ (XCAR (obj
), Qcomma
)
1725 || EQ (XCAR (obj
), Qcomma_at
)
1726 || EQ (XCAR (obj
), Qcomma_dot
))))
1728 print_object (XCAR (obj
), printcharfun
, 0);
1729 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1735 /* If the first element is a backquote form,
1736 print it old-style so it won't be misunderstood. */
1737 if (print_quoted
&& CONSP (XCAR (obj
))
1738 && CONSP (XCDR (XCAR (obj
)))
1739 && NILP (XCDR (XCDR (XCAR (obj
))))
1740 && EQ (XCAR (XCAR (obj
)), Qbackquote
))
1746 print_object (Qbackquote
, printcharfun
, 0);
1749 ++old_backquote_output
;
1750 print_object (XCAR (XCDR (tem
)), printcharfun
, 0);
1751 --old_backquote_output
;
1758 int print_length
, i
;
1759 Lisp_Object halftail
= obj
;
1761 /* Negative values of print-length are invalid in CL.
1762 Treat them like nil, as CMUCL does. */
1763 if (NATNUMP (Vprint_length
))
1764 print_length
= XFASTINT (Vprint_length
);
1771 /* Detect circular list. */
1772 if (NILP (Vprint_circle
))
1774 /* Simple but imcomplete way. */
1775 if (i
!= 0 && EQ (obj
, halftail
))
1777 sprintf (buf
, " . #%d", i
/ 2);
1778 strout (buf
, -1, -1, printcharfun
, 0);
1784 /* With the print-circle feature. */
1788 for (i
= 0; i
< print_number_index
; i
++)
1789 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
),
1792 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1794 strout (" . ", 3, 3, printcharfun
, 0);
1795 print_object (obj
, printcharfun
, escapeflag
);
1799 sprintf (buf
, " . #%d#", i
+ 1);
1800 strout (buf
, -1, -1, printcharfun
, 0);
1810 if (print_length
&& i
> print_length
)
1812 strout ("...", 3, 3, printcharfun
, 0);
1816 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1820 halftail
= XCDR (halftail
);
1824 /* OBJ non-nil here means it's the end of a dotted list. */
1827 strout (" . ", 3, 3, printcharfun
, 0);
1828 print_object (obj
, printcharfun
, escapeflag
);
1836 case Lisp_Vectorlike
:
1841 strout ("#<process ", -1, -1, printcharfun
, 0);
1842 print_string (XPROCESS (obj
)->name
, printcharfun
);
1846 print_string (XPROCESS (obj
)->name
, printcharfun
);
1848 else if (BOOL_VECTOR_P (obj
))
1851 register unsigned char c
;
1852 struct gcpro gcpro1
;
1854 = ((XBOOL_VECTOR (obj
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
1855 / BOOL_VECTOR_BITS_PER_CHAR
);
1861 sprintf (buf
, "%ld", (long) XBOOL_VECTOR (obj
)->size
);
1862 strout (buf
, -1, -1, printcharfun
, 0);
1865 /* Don't print more characters than the specified maximum.
1866 Negative values of print-length are invalid. Treat them
1867 like a print-length of nil. */
1868 if (NATNUMP (Vprint_length
)
1869 && XFASTINT (Vprint_length
) < size_in_chars
)
1870 size_in_chars
= XFASTINT (Vprint_length
);
1872 for (i
= 0; i
< size_in_chars
; i
++)
1875 c
= XBOOL_VECTOR (obj
)->data
[i
];
1876 if (c
== '\n' && print_escape_newlines
)
1881 else if (c
== '\f' && print_escape_newlines
)
1886 else if (c
> '\177')
1888 /* Use octal escapes to avoid encoding issues. */
1890 PRINTCHAR ('0' + ((c
>> 6) & 3));
1891 PRINTCHAR ('0' + ((c
>> 3) & 7));
1892 PRINTCHAR ('0' + (c
& 7));
1896 if (c
== '\"' || c
== '\\')
1905 else if (SUBRP (obj
))
1907 strout ("#<subr ", -1, -1, printcharfun
, 0);
1908 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
, 0);
1911 else if (WINDOWP (obj
))
1913 strout ("#<window ", -1, -1, printcharfun
, 0);
1914 sprintf (buf
, "%ld", (long) XFASTINT (XWINDOW (obj
)->sequence_number
));
1915 strout (buf
, -1, -1, printcharfun
, 0);
1916 if (!NILP (XWINDOW (obj
)->buffer
))
1918 strout (" on ", -1, -1, printcharfun
, 0);
1919 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1923 else if (HASH_TABLE_P (obj
))
1925 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1926 strout ("#<hash-table", -1, -1, printcharfun
, 0);
1927 if (SYMBOLP (h
->test
))
1931 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
, 0);
1933 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
, 0);
1935 sprintf (buf
, "%ld/%ld", (long) XFASTINT (h
->count
),
1936 (long) XVECTOR (h
->next
)->size
);
1937 strout (buf
, -1, -1, printcharfun
, 0);
1939 sprintf (buf
, " 0x%lx", (unsigned long) h
);
1940 strout (buf
, -1, -1, printcharfun
, 0);
1943 else if (BUFFERP (obj
))
1945 if (NILP (XBUFFER (obj
)->name
))
1946 strout ("#<killed buffer>", -1, -1, printcharfun
, 0);
1947 else if (escapeflag
)
1949 strout ("#<buffer ", -1, -1, printcharfun
, 0);
1950 print_string (XBUFFER (obj
)->name
, printcharfun
);
1954 print_string (XBUFFER (obj
)->name
, printcharfun
);
1956 else if (WINDOW_CONFIGURATIONP (obj
))
1958 strout ("#<window-configuration>", -1, -1, printcharfun
, 0);
1960 else if (FRAMEP (obj
))
1962 strout ((FRAME_LIVE_P (XFRAME (obj
))
1963 ? "#<frame " : "#<dead frame "),
1964 -1, -1, printcharfun
, 0);
1965 print_string (XFRAME (obj
)->name
, printcharfun
);
1966 sprintf (buf
, " 0x%lx", (unsigned long) (XFRAME (obj
)));
1967 strout (buf
, -1, -1, printcharfun
, 0);
1972 EMACS_INT size
= XVECTOR (obj
)->size
;
1973 if (COMPILEDP (obj
))
1976 size
&= PSEUDOVECTOR_SIZE_MASK
;
1978 if (CHAR_TABLE_P (obj
))
1980 /* We print a char-table as if it were a vector,
1981 lumping the parent and default slots in with the
1982 character slots. But we add #^ as a prefix. */
1985 if (SUB_CHAR_TABLE_P (obj
))
1987 size
&= PSEUDOVECTOR_SIZE_MASK
;
1989 if (size
& PSEUDOVECTOR_FLAG
)
1995 register Lisp_Object tem
;
1996 int real_size
= size
;
1998 /* Don't print more elements than the specified maximum. */
1999 if (NATNUMP (Vprint_length
)
2000 && XFASTINT (Vprint_length
) < size
)
2001 size
= XFASTINT (Vprint_length
);
2003 for (i
= 0; i
< size
; i
++)
2005 if (i
) PRINTCHAR (' ');
2006 tem
= XVECTOR (obj
)->contents
[i
];
2007 print_object (tem
, printcharfun
, escapeflag
);
2009 if (size
< real_size
)
2010 strout (" ...", 4, 4, printcharfun
, 0);
2017 switch (XMISCTYPE (obj
))
2019 case Lisp_Misc_Marker
:
2020 strout ("#<marker ", -1, -1, printcharfun
, 0);
2021 /* Do you think this is necessary? */
2022 if (XMARKER (obj
)->insertion_type
!= 0)
2023 strout ("(moves after insertion) ", -1, -1, printcharfun
, 0);
2024 if (!(XMARKER (obj
)->buffer
))
2025 strout ("in no buffer", -1, -1, printcharfun
, 0);
2028 sprintf (buf
, "at %d", marker_position (obj
));
2029 strout (buf
, -1, -1, printcharfun
, 0);
2030 strout (" in ", -1, -1, printcharfun
, 0);
2031 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
2036 case Lisp_Misc_Overlay
:
2037 strout ("#<overlay ", -1, -1, printcharfun
, 0);
2038 if (!(XMARKER (OVERLAY_START (obj
))->buffer
))
2039 strout ("in no buffer", -1, -1, printcharfun
, 0);
2042 sprintf (buf
, "from %d to %d in ",
2043 marker_position (OVERLAY_START (obj
)),
2044 marker_position (OVERLAY_END (obj
)));
2045 strout (buf
, -1, -1, printcharfun
, 0);
2046 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
2052 /* Remaining cases shouldn't happen in normal usage, but let's print
2053 them anyway for the benefit of the debugger. */
2054 case Lisp_Misc_Free
:
2055 strout ("#<misc free cell>", -1, -1, printcharfun
, 0);
2058 case Lisp_Misc_Intfwd
:
2059 sprintf (buf
, "#<intfwd to %ld>", (long) *XINTFWD (obj
)->intvar
);
2060 strout (buf
, -1, -1, printcharfun
, 0);
2063 case Lisp_Misc_Boolfwd
:
2064 sprintf (buf
, "#<boolfwd to %s>",
2065 (*XBOOLFWD (obj
)->boolvar
? "t" : "nil"));
2066 strout (buf
, -1, -1, printcharfun
, 0);
2069 case Lisp_Misc_Objfwd
:
2070 strout ("#<objfwd to ", -1, -1, printcharfun
, 0);
2071 print_object (*XOBJFWD (obj
)->objvar
, printcharfun
, escapeflag
);
2075 case Lisp_Misc_Buffer_Objfwd
:
2076 strout ("#<buffer_objfwd to ", -1, -1, printcharfun
, 0);
2077 print_object (PER_BUFFER_VALUE (current_buffer
,
2078 XBUFFER_OBJFWD (obj
)->offset
),
2079 printcharfun
, escapeflag
);
2083 case Lisp_Misc_Kboard_Objfwd
:
2084 strout ("#<kboard_objfwd to ", -1, -1, printcharfun
, 0);
2085 print_object (*(Lisp_Object
*)((char *) current_kboard
2086 + XKBOARD_OBJFWD (obj
)->offset
),
2087 printcharfun
, escapeflag
);
2091 case Lisp_Misc_Buffer_Local_Value
:
2092 strout ("#<buffer_local_value ", -1, -1, printcharfun
, 0);
2093 goto do_buffer_local
;
2094 case Lisp_Misc_Some_Buffer_Local_Value
:
2095 strout ("#<some_buffer_local_value ", -1, -1, printcharfun
, 0);
2097 strout ("[realvalue] ", -1, -1, printcharfun
, 0);
2098 print_object (XBUFFER_LOCAL_VALUE (obj
)->realvalue
,
2099 printcharfun
, escapeflag
);
2100 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_buffer
)
2101 strout ("[local in buffer] ", -1, -1, printcharfun
, 0);
2103 strout ("[buffer] ", -1, -1, printcharfun
, 0);
2104 print_object (XBUFFER_LOCAL_VALUE (obj
)->buffer
,
2105 printcharfun
, escapeflag
);
2106 if (XBUFFER_LOCAL_VALUE (obj
)->check_frame
)
2108 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_frame
)
2109 strout ("[local in frame] ", -1, -1, printcharfun
, 0);
2111 strout ("[frame] ", -1, -1, printcharfun
, 0);
2112 print_object (XBUFFER_LOCAL_VALUE (obj
)->frame
,
2113 printcharfun
, escapeflag
);
2115 strout ("[alist-elt] ", -1, -1, printcharfun
, 0);
2116 print_object (XCAR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
2117 printcharfun
, escapeflag
);
2118 strout ("[default-value] ", -1, -1, printcharfun
, 0);
2119 print_object (XCDR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
2120 printcharfun
, escapeflag
);
2124 case Lisp_Misc_Save_Value
:
2125 strout ("#<save_value ", -1, -1, printcharfun
, 0);
2126 sprintf(buf
, "ptr=0x%08lx int=%d",
2127 (unsigned long) XSAVE_VALUE (obj
)->pointer
,
2128 XSAVE_VALUE (obj
)->integer
);
2129 strout (buf
, -1, -1, printcharfun
, 0);
2141 /* We're in trouble if this happens!
2142 Probably should just abort () */
2143 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
, 0);
2145 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2146 else if (VECTORLIKEP (obj
))
2147 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
2149 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2150 strout (buf
, -1, -1, printcharfun
, 0);
2151 strout (" Save your buffers immediately and please report this bug>",
2152 -1, -1, printcharfun
, 0);
2160 /* Print a description of INTERVAL using PRINTCHARFUN.
2161 This is part of printing a string that has text properties. */
2164 print_interval (interval
, printcharfun
)
2166 Lisp_Object printcharfun
;
2169 print_object (make_number (interval
->position
), printcharfun
, 1);
2171 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2174 print_object (interval
->plist
, printcharfun
, 1);
2181 Qtemp_buffer_setup_hook
= intern ("temp-buffer-setup-hook");
2182 staticpro (&Qtemp_buffer_setup_hook
);
2184 DEFVAR_LISP ("standard-output", &Vstandard_output
,
2185 doc
: /* Output stream `print' uses by default for outputting a character.
2186 This may be any function of one argument.
2187 It may also be a buffer (output is inserted before point)
2188 or a marker (output is inserted and the marker is advanced)
2189 or the symbol t (output appears in the echo area). */);
2190 Vstandard_output
= Qt
;
2191 Qstandard_output
= intern ("standard-output");
2192 staticpro (&Qstandard_output
);
2194 DEFVAR_LISP ("float-output-format", &Vfloat_output_format
,
2195 doc
: /* The format descriptor string used to print floats.
2196 This is a %-spec like those accepted by `printf' in C,
2197 but with some restrictions. It must start with the two characters `%.'.
2198 After that comes an integer precision specification,
2199 and then a letter which controls the format.
2200 The letters allowed are `e', `f' and `g'.
2201 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2202 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2203 Use `g' to choose the shorter of those two formats for the number at hand.
2204 The precision in any of these cases is the number of digits following
2205 the decimal point. With `f', a precision of 0 means to omit the
2206 decimal point. 0 is not allowed with `e' or `g'.
2208 A value of nil means to use the shortest notation
2209 that represents the number without losing information. */);
2210 Vfloat_output_format
= Qnil
;
2211 Qfloat_output_format
= intern ("float-output-format");
2212 staticpro (&Qfloat_output_format
);
2214 DEFVAR_LISP ("print-length", &Vprint_length
,
2215 doc
: /* Maximum length of list to print before abbreviating.
2216 A value of nil means no limit. See also `eval-expression-print-length'. */);
2217 Vprint_length
= Qnil
;
2219 DEFVAR_LISP ("print-level", &Vprint_level
,
2220 doc
: /* Maximum depth of list nesting to print before abbreviating.
2221 A value of nil means no limit. See also `eval-expression-print-level'. */);
2222 Vprint_level
= Qnil
;
2224 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines
,
2225 doc
: /* Non-nil means print newlines in strings as `\\n'.
2226 Also print formfeeds as `\\f'. */);
2227 print_escape_newlines
= 0;
2229 DEFVAR_BOOL ("print-escape-nonascii", &print_escape_nonascii
,
2230 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2231 \(OOO is the octal representation of the character code.)
2232 Only single-byte characters are affected, and only in `prin1'.
2233 When the output goes in a multibyte buffer, this feature is
2234 enabled regardless of the value of the variable. */);
2235 print_escape_nonascii
= 0;
2237 DEFVAR_BOOL ("print-escape-multibyte", &print_escape_multibyte
,
2238 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2239 \(XXXX is the hex representation of the character code.)
2240 This affects only `prin1'. */);
2241 print_escape_multibyte
= 0;
2243 DEFVAR_BOOL ("print-quoted", &print_quoted
,
2244 doc
: /* Non-nil means print quoted forms with reader syntax.
2245 I.e., (quote foo) prints as 'foo, (function foo) as #'foo, and backquoted
2246 forms print as in the new syntax. */);
2249 DEFVAR_LISP ("print-gensym", &Vprint_gensym
,
2250 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2251 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2252 When the uninterned symbol appears within a recursive data structure,
2253 and the symbol appears more than once, in addition use the #N# and #N=
2254 constructs as needed, so that multiple references to the same symbol are
2255 shared once again when the text is read back. */);
2256 Vprint_gensym
= Qnil
;
2258 DEFVAR_LISP ("print-circle", &Vprint_circle
,
2259 doc
: /* *Non-nil means print recursive structures using #N= and #N# syntax.
2260 If nil, printing proceeds recursively and may lead to
2261 `max-lisp-eval-depth' being exceeded or an error may occur:
2262 \"Apparently circular structure being printed.\" Also see
2263 `print-length' and `print-level'.
2264 If non-nil, shared substructures anywhere in the structure are printed
2265 with `#N=' before the first occurrence (in the order of the print
2266 representation) and `#N#' in place of each subsequent occurrence,
2267 where N is a positive decimal integer. */);
2268 Vprint_circle
= Qnil
;
2270 DEFVAR_LISP ("print-continuous-numbering", &Vprint_continuous_numbering
,
2271 doc
: /* *Non-nil means number continuously across print calls.
2272 This affects the numbers printed for #N= labels and #M# references.
2273 See also `print-circle', `print-gensym', and `print-number-table'.
2274 This variable should not be set with `setq'; bind it with a `let' instead. */);
2275 Vprint_continuous_numbering
= Qnil
;
2277 DEFVAR_LISP ("print-number-table", &Vprint_number_table
,
2278 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2279 The Lisp printer uses this vector to detect Lisp objects referenced more
2282 When you bind `print-continuous-numbering' to t, you should probably
2283 also bind `print-number-table' to nil. This ensures that the value of
2284 `print-number-table' can be garbage-collected once the printing is
2285 done. If all elements of `print-number-table' are nil, it means that
2286 the printing done so far has not found any shared structure or objects
2287 that need to be recorded in the table. */);
2288 Vprint_number_table
= Qnil
;
2290 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2291 staticpro (&Vprin1_to_string_buffer
);
2294 defsubr (&Sprin1_to_string
);
2295 defsubr (&Serror_message_string
);
2299 defsubr (&Swrite_char
);
2300 defsubr (&Sexternal_debugging_output
);
2301 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2302 defsubr (&Sredirect_debugging_output
);
2305 Qexternal_debugging_output
= intern ("external-debugging-output");
2306 staticpro (&Qexternal_debugging_output
);
2308 Qprint_escape_newlines
= intern ("print-escape-newlines");
2309 staticpro (&Qprint_escape_newlines
);
2311 Qprint_escape_multibyte
= intern ("print-escape-multibyte");
2312 staticpro (&Qprint_escape_multibyte
);
2314 Qprint_escape_nonascii
= intern ("print-escape-nonascii");
2315 staticpro (&Qprint_escape_nonascii
);
2317 defsubr (&Swith_output_to_temp_buffer
);
2320 /* arch-tag: bc797170-94ae-41de-86e3-75e20f8f7a39
2321 (do not change this comment) */