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 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 ();
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 (STRING_MULTIBYTE (string
))
472 chars
= SCHARS (string
);
473 else if (EQ (printcharfun
, Qt
)
474 ? ! NILP (buffer_defaults
.enable_multibyte_characters
)
475 : ! NILP (current_buffer
->enable_multibyte_characters
))
477 /* If unibyte string STRING contains 8-bit codes, we must
478 convert STRING to a multibyte string containing the same
483 chars
= SBYTES (string
);
484 bytes
= parse_str_to_multibyte (SDATA (string
), chars
);
487 newstr
= make_uninit_multibyte_string (chars
, bytes
);
488 bcopy (SDATA (string
), SDATA (newstr
), chars
);
489 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
494 chars
= SBYTES (string
);
496 /* strout is safe for output to a frame (echo area) or to print_buffer. */
497 strout (SDATA (string
),
498 chars
, SBYTES (string
),
499 printcharfun
, STRING_MULTIBYTE (string
));
503 /* Otherwise, string may be relocated by printing one char.
504 So re-fetch the string address for each character. */
506 int size
= SCHARS (string
);
507 int size_byte
= SBYTES (string
);
510 if (size
== size_byte
)
511 for (i
= 0; i
< size
; i
++)
512 PRINTCHAR (SREF (string
, i
));
514 for (i
= 0; i
< size_byte
; )
516 /* Here, we must convert each multi-byte form to the
517 corresponding character code before handing it to PRINTCHAR. */
519 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
,
521 if (!CHAR_VALID_P (ch
, 0))
523 ch
= SREF (string
, i
);
533 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
534 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
535 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
536 (character
, printcharfun
)
537 Lisp_Object character
, printcharfun
;
541 if (NILP (printcharfun
))
542 printcharfun
= Vstandard_output
;
543 CHECK_NUMBER (character
);
545 PRINTCHAR (XINT (character
));
550 /* Used from outside of print.c to print a block of SIZE
551 single-byte chars at DATA on the default output stream.
552 Do not use this on the contents of a Lisp string. */
555 write_string (data
, size
)
560 Lisp_Object printcharfun
;
562 printcharfun
= Vstandard_output
;
565 strout (data
, size
, size
, printcharfun
, 0);
569 /* Used from outside of print.c to print a block of SIZE
570 single-byte chars at DATA on a specified stream PRINTCHARFUN.
571 Do not use this on the contents of a Lisp string. */
574 write_string_1 (data
, size
, printcharfun
)
577 Lisp_Object printcharfun
;
582 strout (data
, size
, size
, printcharfun
, 0);
588 temp_output_buffer_setup (bufname
)
591 int count
= SPECPDL_INDEX ();
592 register struct buffer
*old
= current_buffer
;
593 register Lisp_Object buf
;
595 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
597 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
599 Fkill_all_local_variables ();
600 delete_all_overlays (current_buffer
);
601 current_buffer
->directory
= old
->directory
;
602 current_buffer
->read_only
= Qnil
;
603 current_buffer
->filename
= Qnil
;
604 current_buffer
->undo_list
= Qt
;
605 eassert (current_buffer
->overlays_before
== NULL
);
606 eassert (current_buffer
->overlays_after
== NULL
);
607 current_buffer
->enable_multibyte_characters
608 = buffer_defaults
.enable_multibyte_characters
;
609 specbind (Qinhibit_read_only
, Qt
);
610 specbind (Qinhibit_modification_hooks
, Qt
);
612 XSETBUFFER (buf
, current_buffer
);
614 Frun_hooks (1, &Qtemp_buffer_setup_hook
);
616 unbind_to (count
, Qnil
);
618 specbind (Qstandard_output
, buf
);
622 internal_with_output_to_temp_buffer (bufname
, function
, args
)
624 Lisp_Object (*function
) P_ ((Lisp_Object
));
627 int count
= SPECPDL_INDEX ();
628 Lisp_Object buf
, val
;
632 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
633 temp_output_buffer_setup (bufname
);
634 buf
= Vstandard_output
;
637 val
= (*function
) (args
);
640 temp_output_buffer_show (buf
);
643 return unbind_to (count
, val
);
646 DEFUN ("with-output-to-temp-buffer",
647 Fwith_output_to_temp_buffer
, Swith_output_to_temp_buffer
,
649 doc
: /* Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
650 The buffer is cleared out initially, and marked as unmodified when done.
651 All output done by BODY is inserted in that buffer by default.
652 The buffer is displayed in another window, but not selected.
653 The value of the last form in BODY is returned.
654 If BODY does not finish normally, the buffer BUFNAME is not displayed.
656 The hook `temp-buffer-setup-hook' is run before BODY,
657 with the buffer BUFNAME temporarily current.
658 The hook `temp-buffer-show-hook' is run after the buffer is displayed,
659 with the buffer temporarily current, and the window that was used
660 to display it temporarily selected.
662 If variable `temp-buffer-show-function' is non-nil, call it at the end
663 to get the buffer displayed instead of just displaying the non-selected
664 buffer and calling the hook. It gets one argument, the buffer to display.
666 usage: (with-output-to-temp-buffer BUFNAME BODY ...) */)
672 int count
= SPECPDL_INDEX ();
673 Lisp_Object buf
, val
;
676 name
= Feval (Fcar (args
));
678 temp_output_buffer_setup (SDATA (name
));
679 buf
= Vstandard_output
;
682 val
= Fprogn (XCDR (args
));
685 temp_output_buffer_show (buf
);
688 return unbind_to (count
, val
);
692 static void print ();
693 static void print_preprocess ();
694 static void print_preprocess_string ();
695 static void print_object ();
697 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
698 doc
: /* Output a newline to stream PRINTCHARFUN.
699 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
701 Lisp_Object printcharfun
;
705 if (NILP (printcharfun
))
706 printcharfun
= Vstandard_output
;
713 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
714 doc
: /* Output the printed representation of OBJECT, any Lisp object.
715 Quoting characters are printed when needed to make output that `read'
716 can handle, whenever this is possible. For complex objects, the behavior
717 is controlled by `print-level' and `print-length', which see.
719 OBJECT is any of the Lisp data types: a number, a string, a symbol,
720 a list, a buffer, a window, a frame, etc.
722 A printed representation of an object is text which describes that object.
724 Optional argument PRINTCHARFUN is the output stream, which can be one
727 - a buffer, in which case output is inserted into that buffer at point;
728 - a marker, in which case output is inserted at marker's position;
729 - a function, in which case that function is called once for each
730 character of OBJECT's printed representation;
731 - a symbol, in which case that symbol's function definition is called; or
732 - t, in which case the output is displayed in the echo area.
734 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
736 (object
, printcharfun
)
737 Lisp_Object object
, printcharfun
;
741 #ifdef MAX_PRINT_CHARS
743 #endif /* MAX_PRINT_CHARS */
744 if (NILP (printcharfun
))
745 printcharfun
= Vstandard_output
;
747 print (object
, printcharfun
, 1);
752 /* a buffer which is used to hold output being built by prin1-to-string */
753 Lisp_Object Vprin1_to_string_buffer
;
755 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
756 doc
: /* Return a string containing the printed representation of OBJECT.
757 OBJECT can be any Lisp object. This function outputs quoting characters
758 when necessary to make output that `read' can handle, whenever possible,
759 unless the optional second argument NOESCAPE is non-nil.
761 OBJECT is any of the Lisp data types: a number, a string, a symbol,
762 a list, a buffer, a window, a frame, etc.
764 A printed representation of an object is text which describes that object. */)
766 Lisp_Object object
, noescape
;
768 Lisp_Object printcharfun
;
769 /* struct gcpro gcpro1, gcpro2; */
770 Lisp_Object save_deactivate_mark
;
771 int count
= specpdl_ptr
- specpdl
;
772 struct buffer
*previous
;
774 specbind (Qinhibit_modification_hooks
, Qt
);
779 /* Save and restore this--we are altering a buffer
780 but we don't want to deactivate the mark just for that.
781 No need for specbind, since errors deactivate the mark. */
782 save_deactivate_mark
= Vdeactivate_mark
;
783 /* GCPRO2 (object, save_deactivate_mark); */
786 printcharfun
= Vprin1_to_string_buffer
;
788 print (object
, printcharfun
, NILP (noescape
));
789 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
793 previous
= current_buffer
;
794 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
795 object
= Fbuffer_string ();
796 if (SBYTES (object
) == SCHARS (object
))
797 STRING_SET_UNIBYTE (object
);
799 /* Note that this won't make prepare_to_modify_buffer call
800 ask-user-about-supersession-threat because this buffer
801 does not visit a file. */
803 set_buffer_internal (previous
);
805 Vdeactivate_mark
= save_deactivate_mark
;
809 return unbind_to (count
, object
);
812 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
813 doc
: /* Output the printed representation of OBJECT, any Lisp object.
814 No quoting characters are used; no delimiters are printed around
815 the contents of strings.
817 OBJECT is any of the Lisp data types: a number, a string, a symbol,
818 a list, a buffer, a window, a frame, etc.
820 A printed representation of an object is text which describes that object.
822 Optional argument PRINTCHARFUN is the output stream, which can be one
825 - a buffer, in which case output is inserted into that buffer at point;
826 - a marker, in which case output is inserted at marker's position;
827 - a function, in which case that function is called once for each
828 character of OBJECT's printed representation;
829 - a symbol, in which case that symbol's function definition is called; or
830 - t, in which case the output is displayed in the echo area.
832 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
834 (object
, printcharfun
)
835 Lisp_Object object
, printcharfun
;
839 if (NILP (printcharfun
))
840 printcharfun
= Vstandard_output
;
842 print (object
, printcharfun
, 0);
847 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
848 doc
: /* Output the printed representation of OBJECT, with newlines around it.
849 Quoting characters are printed when needed to make output that `read'
850 can handle, whenever this is possible. For complex objects, the behavior
851 is controlled by `print-level' and `print-length', which see.
853 OBJECT is any of the Lisp data types: a number, a string, a symbol,
854 a list, a buffer, a window, a frame, etc.
856 A printed representation of an object is text which describes that object.
858 Optional argument PRINTCHARFUN is the output stream, which can be one
861 - a buffer, in which case output is inserted into that buffer at point;
862 - a marker, in which case output is inserted at marker's position;
863 - a function, in which case that function is called once for each
864 character of OBJECT's printed representation;
865 - a symbol, in which case that symbol's function definition is called; or
866 - t, in which case the output is displayed in the echo area.
868 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
870 (object
, printcharfun
)
871 Lisp_Object object
, printcharfun
;
876 #ifdef MAX_PRINT_CHARS
878 max_print
= MAX_PRINT_CHARS
;
879 #endif /* MAX_PRINT_CHARS */
880 if (NILP (printcharfun
))
881 printcharfun
= Vstandard_output
;
885 print (object
, printcharfun
, 1);
888 #ifdef MAX_PRINT_CHARS
891 #endif /* MAX_PRINT_CHARS */
896 /* The subroutine object for external-debugging-output is kept here
897 for the convenience of the debugger. */
898 Lisp_Object Qexternal_debugging_output
;
900 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
901 doc
: /* Write CHARACTER to stderr.
902 You can call print while debugging emacs, and pass it this function
903 to make it write to the debugging output. */)
905 Lisp_Object character
;
907 CHECK_NUMBER (character
);
908 putc (XINT (character
), stderr
);
911 /* Send the output to a debugger (nothing happens if there isn't one). */
913 char buf
[2] = {(char) XINT (character
), '\0'};
914 OutputDebugString (buf
);
922 #if defined(GNU_LINUX)
924 /* This functionality is not vitally important in general, so we rely on
925 non-portable ability to use stderr as lvalue. */
927 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
929 FILE *initial_stderr_stream
= NULL
;
931 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
933 "FDebug output file: \nP",
934 doc
: /* Redirect debugging output (stderr stream) to file FILE.
935 If FILE is nil, reset target to the initial stderr stream.
936 Optional arg APPEND non-nil (interactively, with prefix arg) means
937 append to existing target file. */)
939 Lisp_Object file
, append
;
941 if (initial_stderr_stream
!= NULL
)
943 stderr
= initial_stderr_stream
;
944 initial_stderr_stream
= NULL
;
948 file
= Fexpand_file_name (file
, Qnil
);
949 initial_stderr_stream
= stderr
;
950 stderr
= fopen(SDATA (file
), NILP (append
) ? "w" : "a");
953 stderr
= initial_stderr_stream
;
954 initial_stderr_stream
= NULL
;
955 report_file_error ("Cannot open debugging output stream",
961 #endif /* GNU_LINUX */
964 /* This is the interface for debugging printing. */
970 Fprin1 (arg
, Qexternal_debugging_output
);
971 fprintf (stderr
, "\r\n");
974 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
976 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
977 See Info anchor `(elisp)Definition of signal' for some details on how this
978 error message is constructed. */)
982 struct buffer
*old
= current_buffer
;
986 /* If OBJ is (error STRING), just return STRING.
987 That is not only faster, it also avoids the need to allocate
988 space here when the error is due to memory full. */
989 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
990 && CONSP (XCDR (obj
))
991 && STRINGP (XCAR (XCDR (obj
)))
992 && NILP (XCDR (XCDR (obj
))))
993 return XCAR (XCDR (obj
));
995 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
997 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
998 value
= Fbuffer_string ();
1002 set_buffer_internal (old
);
1008 /* Print an error message for the error DATA onto Lisp output stream
1009 STREAM (suitable for the print functions). */
1012 print_error_message (data
, stream
, context
, caller
)
1013 Lisp_Object data
, stream
;
1017 Lisp_Object errname
, errmsg
, file_error
, tail
;
1018 struct gcpro gcpro1
;
1022 write_string_1 (context
, -1, stream
);
1024 /* If we know from where the error was signaled, show it in
1026 if (!NILP (caller
) && SYMBOLP (caller
))
1028 Lisp_Object cname
= SYMBOL_NAME (caller
);
1029 char *name
= alloca (SBYTES (cname
));
1030 bcopy (SDATA (cname
), name
, SBYTES (cname
));
1031 message_dolog (name
, SBYTES (cname
), 0, 0);
1032 message_dolog (": ", 2, 0, 0);
1035 errname
= Fcar (data
);
1037 if (EQ (errname
, Qerror
))
1042 errmsg
= Fcar (data
);
1047 Lisp_Object error_conditions
;
1048 errmsg
= Fget (errname
, Qerror_message
);
1049 error_conditions
= Fget (errname
, Qerror_conditions
);
1050 file_error
= Fmemq (Qfile_error
, error_conditions
);
1053 /* Print an error message including the data items. */
1055 tail
= Fcdr_safe (data
);
1058 /* For file-error, make error message by concatenating
1059 all the data items. They are all strings. */
1060 if (!NILP (file_error
) && CONSP (tail
))
1061 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
1063 if (STRINGP (errmsg
))
1064 Fprinc (errmsg
, stream
);
1066 write_string_1 ("peculiar error", -1, stream
);
1068 for (i
= 0; CONSP (tail
); tail
= XCDR (tail
), i
++)
1072 write_string_1 (i
? ", " : ": ", 2, stream
);
1074 if (!NILP (file_error
) || EQ (errname
, Qend_of_file
))
1075 Fprinc (obj
, stream
);
1077 Fprin1 (obj
, stream
);
1086 * The buffer should be at least as large as the max string size of the
1087 * largest float, printed in the biggest notation. This is undoubtedly
1088 * 20d float_output_format, with the negative of the C-constant "HUGE"
1091 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
1093 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
1094 * case of -1e307 in 20d float_output_format. What is one to do (short of
1095 * re-writing _doprnt to be more sane)?
1100 float_to_string (buf
, data
)
1107 /* Check for plus infinity in a way that won't lose
1108 if there is no plus infinity. */
1109 if (data
== data
/ 2 && data
> 1.0)
1111 strcpy (buf
, "1.0e+INF");
1114 /* Likewise for minus infinity. */
1115 if (data
== data
/ 2 && data
< -1.0)
1117 strcpy (buf
, "-1.0e+INF");
1120 /* Check for NaN in a way that won't fail if there are no NaNs. */
1121 if (! (data
* 0.0 >= 0.0))
1123 /* Prepend "-" if the NaN's sign bit is negative.
1124 The sign bit of a double is the bit that is 1 in -0.0. */
1126 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
1128 u_minus_zero
.d
= - 0.0;
1129 for (i
= 0; i
< sizeof (double); i
++)
1130 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
1136 strcpy (buf
, "0.0e+NaN");
1140 if (NILP (Vfloat_output_format
)
1141 || !STRINGP (Vfloat_output_format
))
1144 /* Generate the fewest number of digits that represent the
1145 floating point value without losing information.
1146 The following method is simple but a bit slow.
1147 For ideas about speeding things up, please see:
1149 Guy L Steele Jr & Jon L White, How to print floating-point numbers
1150 accurately. SIGPLAN notices 25, 6 (June 1990), 112-126.
1152 Robert G Burger & R Kent Dybvig, Printing floating point numbers
1153 quickly and accurately, SIGPLAN notices 31, 5 (May 1996), 108-116. */
1155 width
= fabs (data
) < DBL_MIN
? 1 : DBL_DIG
;
1157 sprintf (buf
, "%.*g", width
, data
);
1158 while (width
++ < DOUBLE_DIGITS_BOUND
&& atof (buf
) != data
);
1160 else /* oink oink */
1162 /* Check that the spec we have is fully valid.
1163 This means not only valid for printf,
1164 but meant for floats, and reasonable. */
1165 cp
= SDATA (Vfloat_output_format
);
1174 /* Check the width specification. */
1176 if ('0' <= *cp
&& *cp
<= '9')
1180 width
= (width
* 10) + (*cp
++ - '0');
1181 while (*cp
>= '0' && *cp
<= '9');
1183 /* A precision of zero is valid only for %f. */
1185 || (width
== 0 && *cp
!= 'f'))
1189 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1195 sprintf (buf
, SDATA (Vfloat_output_format
), data
);
1198 /* Make sure there is a decimal point with digit after, or an
1199 exponent, so that the value is readable as a float. But don't do
1200 this with "%.0f"; it's valid for that not to produce a decimal
1201 point. Note that width can be 0 only for %.0f. */
1204 for (cp
= buf
; *cp
; cp
++)
1205 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1208 if (*cp
== '.' && cp
[1] == 0)
1225 print (obj
, printcharfun
, escapeflag
)
1227 register Lisp_Object printcharfun
;
1230 old_backquote_output
= 0;
1232 /* Reset print_number_index and Vprint_number_table only when
1233 the variable Vprint_continuous_numbering is nil. Otherwise,
1234 the values of these variables will be kept between several
1236 if (NILP (Vprint_continuous_numbering
))
1238 print_number_index
= 0;
1239 Vprint_number_table
= Qnil
;
1242 /* Construct Vprint_number_table for print-gensym and print-circle. */
1243 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1245 int i
, start
, index
;
1246 start
= index
= print_number_index
;
1247 /* Construct Vprint_number_table.
1248 This increments print_number_index for the objects added. */
1250 print_preprocess (obj
);
1252 /* Remove unnecessary objects, which appear only once in OBJ;
1253 that is, whose status is Qnil. Compactify the necessary objects. */
1254 for (i
= start
; i
< print_number_index
; i
++)
1255 if (!NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1257 PRINT_NUMBER_OBJECT (Vprint_number_table
, index
)
1258 = PRINT_NUMBER_OBJECT (Vprint_number_table
, i
);
1262 /* Clear out objects outside the active part of the table. */
1263 for (i
= index
; i
< print_number_index
; i
++)
1264 PRINT_NUMBER_OBJECT (Vprint_number_table
, i
) = Qnil
;
1266 /* Reset the status field for the next print step. Now this
1267 field means whether the object has already been printed. */
1268 for (i
= start
; i
< print_number_index
; i
++)
1269 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qnil
;
1271 print_number_index
= index
;
1275 print_object (obj
, printcharfun
, escapeflag
);
1278 /* Construct Vprint_number_table according to the structure of OBJ.
1279 OBJ itself and all its elements will be added to Vprint_number_table
1280 recursively if it is a list, vector, compiled function, char-table,
1281 string (its text properties will be traced), or a symbol that has
1282 no obarray (this is for the print-gensym feature).
1283 The status fields of Vprint_number_table mean whether each object appears
1284 more than once in OBJ: Qnil at the first time, and Qt after that . */
1286 print_preprocess (obj
)
1292 Lisp_Object halftail
;
1294 /* Give up if we go so deep that print_object will get an error. */
1295 /* See similar code in print_object. */
1296 if (print_depth
>= PRINT_CIRCLE
)
1299 /* Avoid infinite recursion for circular nested structure
1300 in the case where Vprint_circle is nil. */
1301 if (NILP (Vprint_circle
))
1303 for (i
= 0; i
< print_depth
; i
++)
1304 if (EQ (obj
, being_printed
[i
]))
1306 being_printed
[print_depth
] = obj
;
1313 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1314 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
)
1315 || (! NILP (Vprint_gensym
)
1317 && !SYMBOL_INTERNED_P (obj
)))
1319 /* In case print-circle is nil and print-gensym is t,
1320 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1321 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1323 for (i
= 0; i
< print_number_index
; i
++)
1324 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
), obj
))
1326 /* OBJ appears more than once. Let's remember that. */
1327 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1331 /* OBJ is not yet recorded. Let's add to the table. */
1332 if (print_number_index
== 0)
1334 /* Initialize the table. */
1335 Vprint_number_table
= Fmake_vector (make_number (40), Qnil
);
1337 else if (XVECTOR (Vprint_number_table
)->size
== print_number_index
* 2)
1339 /* Reallocate the table. */
1340 int i
= print_number_index
* 4;
1341 Lisp_Object old_table
= Vprint_number_table
;
1342 Vprint_number_table
= Fmake_vector (make_number (i
), Qnil
);
1343 for (i
= 0; i
< print_number_index
; i
++)
1345 PRINT_NUMBER_OBJECT (Vprint_number_table
, i
)
1346 = PRINT_NUMBER_OBJECT (old_table
, i
);
1347 PRINT_NUMBER_STATUS (Vprint_number_table
, i
)
1348 = PRINT_NUMBER_STATUS (old_table
, i
);
1351 PRINT_NUMBER_OBJECT (Vprint_number_table
, print_number_index
) = obj
;
1352 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1353 always print the gensym with a number. This is a special for
1354 the lisp function byte-compile-output-docform. */
1355 if (!NILP (Vprint_continuous_numbering
)
1357 && !SYMBOL_INTERNED_P (obj
))
1358 PRINT_NUMBER_STATUS (Vprint_number_table
, print_number_index
) = Qt
;
1359 print_number_index
++;
1362 switch (XGCTYPE (obj
))
1365 /* A string may have text properties, which can be circular. */
1366 traverse_intervals_noorder (STRING_INTERVALS (obj
),
1367 print_preprocess_string
, Qnil
);
1371 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1372 just as in print_object. */
1373 if (loop_count
&& EQ (obj
, halftail
))
1375 print_preprocess (XCAR (obj
));
1378 if (!(loop_count
& 1))
1379 halftail
= XCDR (halftail
);
1382 case Lisp_Vectorlike
:
1383 size
= XVECTOR (obj
)->size
;
1384 if (size
& PSEUDOVECTOR_FLAG
)
1385 size
&= PSEUDOVECTOR_SIZE_MASK
;
1386 for (i
= 0; i
< size
; i
++)
1387 print_preprocess (XVECTOR (obj
)->contents
[i
]);
1398 print_preprocess_string (interval
, arg
)
1402 print_preprocess (interval
->plist
);
1406 print_object (obj
, printcharfun
, escapeflag
)
1408 register Lisp_Object printcharfun
;
1415 /* Detect circularities and truncate them. */
1416 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1417 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
)
1418 || (! NILP (Vprint_gensym
)
1420 && !SYMBOL_INTERNED_P (obj
)))
1422 if (NILP (Vprint_circle
) && NILP (Vprint_gensym
))
1424 /* Simple but incomplete way. */
1426 for (i
= 0; i
< print_depth
; i
++)
1427 if (EQ (obj
, being_printed
[i
]))
1429 sprintf (buf
, "#%d", i
);
1430 strout (buf
, -1, -1, printcharfun
, 0);
1433 being_printed
[print_depth
] = obj
;
1437 /* With the print-circle feature. */
1439 for (i
= 0; i
< print_number_index
; i
++)
1440 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
), obj
))
1442 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1444 /* Add a prefix #n= if OBJ has not yet been printed;
1445 that is, its status field is nil. */
1446 sprintf (buf
, "#%d=", i
+ 1);
1447 strout (buf
, -1, -1, printcharfun
, 0);
1448 /* OBJ is going to be printed. Set the status to t. */
1449 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1454 /* Just print #n# if OBJ has already been printed. */
1455 sprintf (buf
, "#%d#", i
+ 1);
1456 strout (buf
, -1, -1, printcharfun
, 0);
1465 /* See similar code in print_preprocess. */
1466 if (print_depth
> PRINT_CIRCLE
)
1467 error ("Apparently circular structure being printed");
1468 #ifdef MAX_PRINT_CHARS
1469 if (max_print
&& print_chars
> max_print
)
1474 #endif /* MAX_PRINT_CHARS */
1476 switch (XGCTYPE (obj
))
1479 if (sizeof (int) == sizeof (EMACS_INT
))
1480 sprintf (buf
, "%d", XINT (obj
));
1481 else if (sizeof (long) == sizeof (EMACS_INT
))
1482 sprintf (buf
, "%ld", (long) XINT (obj
));
1485 strout (buf
, -1, -1, printcharfun
, 0);
1490 char pigbuf
[350]; /* see comments in float_to_string */
1492 float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1493 strout (pigbuf
, -1, -1, printcharfun
, 0);
1499 print_string (obj
, printcharfun
);
1502 register int i
, i_byte
;
1503 struct gcpro gcpro1
;
1506 /* 1 means we must ensure that the next character we output
1507 cannot be taken as part of a hex character escape. */
1508 int need_nonhex
= 0;
1509 int multibyte
= STRING_MULTIBYTE (obj
);
1513 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1521 size_byte
= SBYTES (obj
);
1523 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1525 /* Here, we must convert each multi-byte form to the
1526 corresponding character code before handing it to PRINTCHAR. */
1532 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
,
1533 size_byte
- i_byte
, len
);
1534 if (CHAR_VALID_P (c
, 0))
1544 if (c
== '\n' && print_escape_newlines
)
1549 else if (c
== '\f' && print_escape_newlines
)
1555 && ! ASCII_BYTE_P (c
)
1556 && (SINGLE_BYTE_CHAR_P (c
) || print_escape_multibyte
))
1558 /* When multibyte is disabled,
1559 print multibyte string chars using hex escapes.
1560 For a char code that could be in a unibyte string,
1561 when found in a multibyte string, always use a hex escape
1562 so it reads back as multibyte. */
1563 unsigned char outbuf
[50];
1564 sprintf (outbuf
, "\\x%x", c
);
1565 strout (outbuf
, -1, -1, printcharfun
, 0);
1568 else if (! multibyte
1569 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1570 && print_escape_nonascii
)
1572 /* When printing in a multibyte buffer
1573 or when explicitly requested,
1574 print single-byte non-ASCII string chars
1575 using octal escapes. */
1576 unsigned char outbuf
[5];
1577 sprintf (outbuf
, "\\%03o", c
);
1578 strout (outbuf
, -1, -1, printcharfun
, 0);
1582 /* If we just had a hex escape, and this character
1583 could be taken as part of it,
1584 output `\ ' to prevent that. */
1588 if ((c
>= 'a' && c
<= 'f')
1589 || (c
>= 'A' && c
<= 'F')
1590 || (c
>= '0' && c
<= '9'))
1591 strout ("\\ ", -1, -1, printcharfun
, 0);
1594 if (c
== '\"' || c
== '\\')
1601 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1603 traverse_intervals (STRING_INTERVALS (obj
),
1604 0, print_interval
, printcharfun
);
1614 register int confusing
;
1615 register unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1616 register unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1618 int i
, i_byte
, size_byte
;
1621 name
= SYMBOL_NAME (obj
);
1623 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1626 /* If symbol name begins with a digit, and ends with a digit,
1627 and contains nothing but digits and `e', it could be treated
1628 as a number. So set CONFUSING.
1630 Symbols that contain periods could also be taken as numbers,
1631 but periods are always escaped, so we don't have to worry
1633 else if (*p
>= '0' && *p
<= '9'
1634 && end
[-1] >= '0' && end
[-1] <= '9')
1636 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1637 /* Needed for \2e10. */
1640 confusing
= (end
== p
);
1645 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1651 size_byte
= SBYTES (name
);
1653 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1655 /* Here, we must convert each multi-byte form to the
1656 corresponding character code before handing it to PRINTCHAR. */
1657 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1662 if (c
== '\"' || c
== '\\' || c
== '\''
1663 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1664 || c
== ',' || c
=='.' || c
== '`'
1665 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1667 PRINTCHAR ('\\'), confusing
= 0;
1675 /* If deeper than spec'd depth, print placeholder. */
1676 if (INTEGERP (Vprint_level
)
1677 && print_depth
> XINT (Vprint_level
))
1678 strout ("...", -1, -1, printcharfun
, 0);
1679 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1680 && (EQ (XCAR (obj
), Qquote
)))
1683 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1685 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1686 && (EQ (XCAR (obj
), Qfunction
)))
1690 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1692 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1693 && ! old_backquote_output
1694 && ((EQ (XCAR (obj
), Qbackquote
)
1695 || EQ (XCAR (obj
), Qcomma
)
1696 || EQ (XCAR (obj
), Qcomma_at
)
1697 || EQ (XCAR (obj
), Qcomma_dot
))))
1699 print_object (XCAR (obj
), printcharfun
, 0);
1700 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1706 /* If the first element is a backquote form,
1707 print it old-style so it won't be misunderstood. */
1708 if (print_quoted
&& CONSP (XCAR (obj
))
1709 && CONSP (XCDR (XCAR (obj
)))
1710 && NILP (XCDR (XCDR (XCAR (obj
))))
1711 && EQ (XCAR (XCAR (obj
)), Qbackquote
))
1717 print_object (Qbackquote
, printcharfun
, 0);
1720 ++old_backquote_output
;
1721 print_object (XCAR (XCDR (tem
)), printcharfun
, 0);
1722 --old_backquote_output
;
1729 int print_length
, i
;
1730 Lisp_Object halftail
= obj
;
1732 /* Negative values of print-length are invalid in CL.
1733 Treat them like nil, as CMUCL does. */
1734 if (NATNUMP (Vprint_length
))
1735 print_length
= XFASTINT (Vprint_length
);
1742 /* Detect circular list. */
1743 if (NILP (Vprint_circle
))
1745 /* Simple but imcomplete way. */
1746 if (i
!= 0 && EQ (obj
, halftail
))
1748 sprintf (buf
, " . #%d", i
/ 2);
1749 strout (buf
, -1, -1, printcharfun
, 0);
1755 /* With the print-circle feature. */
1759 for (i
= 0; i
< print_number_index
; i
++)
1760 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
),
1763 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1765 strout (" . ", 3, 3, printcharfun
, 0);
1766 print_object (obj
, printcharfun
, escapeflag
);
1770 sprintf (buf
, " . #%d#", i
+ 1);
1771 strout (buf
, -1, -1, printcharfun
, 0);
1781 if (print_length
&& i
> print_length
)
1783 strout ("...", 3, 3, printcharfun
, 0);
1787 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1791 halftail
= XCDR (halftail
);
1795 /* OBJ non-nil here means it's the end of a dotted list. */
1798 strout (" . ", 3, 3, printcharfun
, 0);
1799 print_object (obj
, printcharfun
, escapeflag
);
1807 case Lisp_Vectorlike
:
1812 strout ("#<process ", -1, -1, printcharfun
, 0);
1813 print_string (XPROCESS (obj
)->name
, printcharfun
);
1817 print_string (XPROCESS (obj
)->name
, printcharfun
);
1819 else if (BOOL_VECTOR_P (obj
))
1822 register unsigned char c
;
1823 struct gcpro gcpro1
;
1825 = ((XBOOL_VECTOR (obj
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
1826 / BOOL_VECTOR_BITS_PER_CHAR
);
1832 sprintf (buf
, "%ld", (long) XBOOL_VECTOR (obj
)->size
);
1833 strout (buf
, -1, -1, printcharfun
, 0);
1836 /* Don't print more characters than the specified maximum.
1837 Negative values of print-length are invalid. Treat them
1838 like a print-length of nil. */
1839 if (NATNUMP (Vprint_length
)
1840 && XFASTINT (Vprint_length
) < size_in_chars
)
1841 size_in_chars
= XFASTINT (Vprint_length
);
1843 for (i
= 0; i
< size_in_chars
; i
++)
1846 c
= XBOOL_VECTOR (obj
)->data
[i
];
1847 if (c
== '\n' && print_escape_newlines
)
1852 else if (c
== '\f' && print_escape_newlines
)
1857 else if (c
> '\177')
1859 /* Use octal escapes to avoid encoding issues. */
1861 PRINTCHAR ('0' + ((c
>> 6) & 3));
1862 PRINTCHAR ('0' + ((c
>> 3) & 7));
1863 PRINTCHAR ('0' + (c
& 7));
1867 if (c
== '\"' || c
== '\\')
1876 else if (SUBRP (obj
))
1878 strout ("#<subr ", -1, -1, printcharfun
, 0);
1879 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
, 0);
1882 else if (WINDOWP (obj
))
1884 strout ("#<window ", -1, -1, printcharfun
, 0);
1885 sprintf (buf
, "%ld", (long) XFASTINT (XWINDOW (obj
)->sequence_number
));
1886 strout (buf
, -1, -1, printcharfun
, 0);
1887 if (!NILP (XWINDOW (obj
)->buffer
))
1889 strout (" on ", -1, -1, printcharfun
, 0);
1890 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1894 else if (HASH_TABLE_P (obj
))
1896 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1897 strout ("#<hash-table", -1, -1, printcharfun
, 0);
1898 if (SYMBOLP (h
->test
))
1902 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
, 0);
1904 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
, 0);
1906 sprintf (buf
, "%ld/%ld", (long) XFASTINT (h
->count
),
1907 (long) XVECTOR (h
->next
)->size
);
1908 strout (buf
, -1, -1, printcharfun
, 0);
1910 sprintf (buf
, " 0x%lx", (unsigned long) h
);
1911 strout (buf
, -1, -1, printcharfun
, 0);
1914 else if (BUFFERP (obj
))
1916 if (NILP (XBUFFER (obj
)->name
))
1917 strout ("#<killed buffer>", -1, -1, printcharfun
, 0);
1918 else if (escapeflag
)
1920 strout ("#<buffer ", -1, -1, printcharfun
, 0);
1921 print_string (XBUFFER (obj
)->name
, printcharfun
);
1925 print_string (XBUFFER (obj
)->name
, printcharfun
);
1927 else if (WINDOW_CONFIGURATIONP (obj
))
1929 strout ("#<window-configuration>", -1, -1, printcharfun
, 0);
1931 else if (FRAMEP (obj
))
1933 strout ((FRAME_LIVE_P (XFRAME (obj
))
1934 ? "#<frame " : "#<dead frame "),
1935 -1, -1, printcharfun
, 0);
1936 print_string (XFRAME (obj
)->name
, printcharfun
);
1937 sprintf (buf
, " 0x%lx", (unsigned long) (XFRAME (obj
)));
1938 strout (buf
, -1, -1, printcharfun
, 0);
1943 EMACS_INT size
= XVECTOR (obj
)->size
;
1944 if (COMPILEDP (obj
))
1947 size
&= PSEUDOVECTOR_SIZE_MASK
;
1949 if (CHAR_TABLE_P (obj
))
1951 /* We print a char-table as if it were a vector,
1952 lumping the parent and default slots in with the
1953 character slots. But we add #^ as a prefix. */
1956 if (SUB_CHAR_TABLE_P (obj
))
1958 size
&= PSEUDOVECTOR_SIZE_MASK
;
1960 if (size
& PSEUDOVECTOR_FLAG
)
1966 register Lisp_Object tem
;
1967 int real_size
= size
;
1969 /* Don't print more elements than the specified maximum. */
1970 if (NATNUMP (Vprint_length
)
1971 && XFASTINT (Vprint_length
) < size
)
1972 size
= XFASTINT (Vprint_length
);
1974 for (i
= 0; i
< size
; i
++)
1976 if (i
) PRINTCHAR (' ');
1977 tem
= XVECTOR (obj
)->contents
[i
];
1978 print_object (tem
, printcharfun
, escapeflag
);
1980 if (size
< real_size
)
1981 strout (" ...", 4, 4, printcharfun
, 0);
1988 switch (XMISCTYPE (obj
))
1990 case Lisp_Misc_Marker
:
1991 strout ("#<marker ", -1, -1, printcharfun
, 0);
1992 /* Do you think this is necessary? */
1993 if (XMARKER (obj
)->insertion_type
!= 0)
1994 strout ("(moves after insertion) ", -1, -1, printcharfun
, 0);
1995 if (!(XMARKER (obj
)->buffer
))
1996 strout ("in no buffer", -1, -1, printcharfun
, 0);
1999 sprintf (buf
, "at %d", marker_position (obj
));
2000 strout (buf
, -1, -1, printcharfun
, 0);
2001 strout (" in ", -1, -1, printcharfun
, 0);
2002 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
2007 case Lisp_Misc_Overlay
:
2008 strout ("#<overlay ", -1, -1, printcharfun
, 0);
2009 if (!(XMARKER (OVERLAY_START (obj
))->buffer
))
2010 strout ("in no buffer", -1, -1, printcharfun
, 0);
2013 sprintf (buf
, "from %d to %d in ",
2014 marker_position (OVERLAY_START (obj
)),
2015 marker_position (OVERLAY_END (obj
)));
2016 strout (buf
, -1, -1, printcharfun
, 0);
2017 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
2023 /* Remaining cases shouldn't happen in normal usage, but let's print
2024 them anyway for the benefit of the debugger. */
2025 case Lisp_Misc_Free
:
2026 strout ("#<misc free cell>", -1, -1, printcharfun
, 0);
2029 case Lisp_Misc_Intfwd
:
2030 sprintf (buf
, "#<intfwd to %ld>", (long) *XINTFWD (obj
)->intvar
);
2031 strout (buf
, -1, -1, printcharfun
, 0);
2034 case Lisp_Misc_Boolfwd
:
2035 sprintf (buf
, "#<boolfwd to %s>",
2036 (*XBOOLFWD (obj
)->boolvar
? "t" : "nil"));
2037 strout (buf
, -1, -1, printcharfun
, 0);
2040 case Lisp_Misc_Objfwd
:
2041 strout ("#<objfwd to ", -1, -1, printcharfun
, 0);
2042 print_object (*XOBJFWD (obj
)->objvar
, printcharfun
, escapeflag
);
2046 case Lisp_Misc_Buffer_Objfwd
:
2047 strout ("#<buffer_objfwd to ", -1, -1, printcharfun
, 0);
2048 print_object (PER_BUFFER_VALUE (current_buffer
,
2049 XBUFFER_OBJFWD (obj
)->offset
),
2050 printcharfun
, escapeflag
);
2054 case Lisp_Misc_Kboard_Objfwd
:
2055 strout ("#<kboard_objfwd to ", -1, -1, printcharfun
, 0);
2056 print_object (*(Lisp_Object
*)((char *) current_kboard
2057 + XKBOARD_OBJFWD (obj
)->offset
),
2058 printcharfun
, escapeflag
);
2062 case Lisp_Misc_Buffer_Local_Value
:
2063 strout ("#<buffer_local_value ", -1, -1, printcharfun
, 0);
2064 goto do_buffer_local
;
2065 case Lisp_Misc_Some_Buffer_Local_Value
:
2066 strout ("#<some_buffer_local_value ", -1, -1, printcharfun
, 0);
2068 strout ("[realvalue] ", -1, -1, printcharfun
, 0);
2069 print_object (XBUFFER_LOCAL_VALUE (obj
)->realvalue
,
2070 printcharfun
, escapeflag
);
2071 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_buffer
)
2072 strout ("[local in buffer] ", -1, -1, printcharfun
, 0);
2074 strout ("[buffer] ", -1, -1, printcharfun
, 0);
2075 print_object (XBUFFER_LOCAL_VALUE (obj
)->buffer
,
2076 printcharfun
, escapeflag
);
2077 if (XBUFFER_LOCAL_VALUE (obj
)->check_frame
)
2079 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_frame
)
2080 strout ("[local in frame] ", -1, -1, printcharfun
, 0);
2082 strout ("[frame] ", -1, -1, printcharfun
, 0);
2083 print_object (XBUFFER_LOCAL_VALUE (obj
)->frame
,
2084 printcharfun
, escapeflag
);
2086 strout ("[alist-elt] ", -1, -1, printcharfun
, 0);
2087 print_object (XCAR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
2088 printcharfun
, escapeflag
);
2089 strout ("[default-value] ", -1, -1, printcharfun
, 0);
2090 print_object (XCDR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
2091 printcharfun
, escapeflag
);
2095 case Lisp_Misc_Save_Value
:
2096 strout ("#<save_value ", -1, -1, printcharfun
, 0);
2097 sprintf(buf
, "ptr=0x%08lx int=%d",
2098 (unsigned long) XSAVE_VALUE (obj
)->pointer
,
2099 XSAVE_VALUE (obj
)->integer
);
2100 strout (buf
, -1, -1, printcharfun
, 0);
2112 /* We're in trouble if this happens!
2113 Probably should just abort () */
2114 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
, 0);
2116 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2117 else if (VECTORLIKEP (obj
))
2118 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
2120 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2121 strout (buf
, -1, -1, printcharfun
, 0);
2122 strout (" Save your buffers immediately and please report this bug>",
2123 -1, -1, printcharfun
, 0);
2131 /* Print a description of INTERVAL using PRINTCHARFUN.
2132 This is part of printing a string that has text properties. */
2135 print_interval (interval
, printcharfun
)
2137 Lisp_Object printcharfun
;
2140 print_object (make_number (interval
->position
), printcharfun
, 1);
2142 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2145 print_object (interval
->plist
, printcharfun
, 1);
2152 Qtemp_buffer_setup_hook
= intern ("temp-buffer-setup-hook");
2153 staticpro (&Qtemp_buffer_setup_hook
);
2155 DEFVAR_LISP ("standard-output", &Vstandard_output
,
2156 doc
: /* Output stream `print' uses by default for outputting a character.
2157 This may be any function of one argument.
2158 It may also be a buffer (output is inserted before point)
2159 or a marker (output is inserted and the marker is advanced)
2160 or the symbol t (output appears in the echo area). */);
2161 Vstandard_output
= Qt
;
2162 Qstandard_output
= intern ("standard-output");
2163 staticpro (&Qstandard_output
);
2165 DEFVAR_LISP ("float-output-format", &Vfloat_output_format
,
2166 doc
: /* The format descriptor string used to print floats.
2167 This is a %-spec like those accepted by `printf' in C,
2168 but with some restrictions. It must start with the two characters `%.'.
2169 After that comes an integer precision specification,
2170 and then a letter which controls the format.
2171 The letters allowed are `e', `f' and `g'.
2172 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2173 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2174 Use `g' to choose the shorter of those two formats for the number at hand.
2175 The precision in any of these cases is the number of digits following
2176 the decimal point. With `f', a precision of 0 means to omit the
2177 decimal point. 0 is not allowed with `e' or `g'.
2179 A value of nil means to use the shortest notation
2180 that represents the number without losing information. */);
2181 Vfloat_output_format
= Qnil
;
2182 Qfloat_output_format
= intern ("float-output-format");
2183 staticpro (&Qfloat_output_format
);
2185 DEFVAR_LISP ("print-length", &Vprint_length
,
2186 doc
: /* Maximum length of list to print before abbreviating.
2187 A value of nil means no limit. See also `eval-expression-print-length'. */);
2188 Vprint_length
= Qnil
;
2190 DEFVAR_LISP ("print-level", &Vprint_level
,
2191 doc
: /* Maximum depth of list nesting to print before abbreviating.
2192 A value of nil means no limit. See also `eval-expression-print-level'. */);
2193 Vprint_level
= Qnil
;
2195 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines
,
2196 doc
: /* Non-nil means print newlines in strings as `\\n'.
2197 Also print formfeeds as `\\f'. */);
2198 print_escape_newlines
= 0;
2200 DEFVAR_BOOL ("print-escape-nonascii", &print_escape_nonascii
,
2201 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2202 \(OOO is the octal representation of the character code.)
2203 Only single-byte characters are affected, and only in `prin1'.
2204 When the output goes in a multibyte buffer, this feature is
2205 enabled regardless of the value of the variable. */);
2206 print_escape_nonascii
= 0;
2208 DEFVAR_BOOL ("print-escape-multibyte", &print_escape_multibyte
,
2209 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2210 \(XXXX is the hex representation of the character code.)
2211 This affects only `prin1'. */);
2212 print_escape_multibyte
= 0;
2214 DEFVAR_BOOL ("print-quoted", &print_quoted
,
2215 doc
: /* Non-nil means print quoted forms with reader syntax.
2216 I.e., (quote foo) prints as 'foo, (function foo) as #'foo, and backquoted
2217 forms print as in the new syntax. */);
2220 DEFVAR_LISP ("print-gensym", &Vprint_gensym
,
2221 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2222 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2223 When the uninterned symbol appears within a recursive data structure,
2224 and the symbol appears more than once, in addition use the #N# and #N=
2225 constructs as needed, so that multiple references to the same symbol are
2226 shared once again when the text is read back. */);
2227 Vprint_gensym
= Qnil
;
2229 DEFVAR_LISP ("print-circle", &Vprint_circle
,
2230 doc
: /* *Non-nil means print recursive structures using #N= and #N# syntax.
2231 If nil, printing proceeds recursively and may lead to
2232 `max-lisp-eval-depth' being exceeded or an error may occur:
2233 \"Apparently circular structure being printed.\" Also see
2234 `print-length' and `print-level'.
2235 If non-nil, shared substructures anywhere in the structure are printed
2236 with `#N=' before the first occurrence (in the order of the print
2237 representation) and `#N#' in place of each subsequent occurrence,
2238 where N is a positive decimal integer. */);
2239 Vprint_circle
= Qnil
;
2241 DEFVAR_LISP ("print-continuous-numbering", &Vprint_continuous_numbering
,
2242 doc
: /* *Non-nil means number continuously across print calls.
2243 This affects the numbers printed for #N= labels and #M# references.
2244 See also `print-circle', `print-gensym', and `print-number-table'.
2245 This variable should not be set with `setq'; bind it with a `let' instead. */);
2246 Vprint_continuous_numbering
= Qnil
;
2248 DEFVAR_LISP ("print-number-table", &Vprint_number_table
,
2249 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2250 The Lisp printer uses this vector to detect Lisp objects referenced more
2253 When you bind `print-continuous-numbering' to t, you should probably
2254 also bind `print-number-table' to nil. This ensures that the value of
2255 `print-number-table' can be garbage-collected once the printing is
2256 done. If all elements of `print-number-table' are nil, it means that
2257 the printing done so far has not found any shared structure or objects
2258 that need to be recorded in the table. */);
2259 Vprint_number_table
= Qnil
;
2261 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2262 staticpro (&Vprin1_to_string_buffer
);
2265 defsubr (&Sprin1_to_string
);
2266 defsubr (&Serror_message_string
);
2270 defsubr (&Swrite_char
);
2271 defsubr (&Sexternal_debugging_output
);
2272 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2273 defsubr (&Sredirect_debugging_output
);
2276 Qexternal_debugging_output
= intern ("external-debugging-output");
2277 staticpro (&Qexternal_debugging_output
);
2279 Qprint_escape_newlines
= intern ("print-escape-newlines");
2280 staticpro (&Qprint_escape_newlines
);
2282 Qprint_escape_multibyte
= intern ("print-escape-multibyte");
2283 staticpro (&Qprint_escape_multibyte
);
2285 Qprint_escape_nonascii
= intern ("print-escape-nonascii");
2286 staticpro (&Qprint_escape_nonascii
);
2288 defsubr (&Swith_output_to_temp_buffer
);
2291 /* arch-tag: bc797170-94ae-41de-86e3-75e20f8f7a39
2292 (do not change this comment) */