1 /* Lisp object printing and output streams.
2 Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000, 01, 2003
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
32 #include "dispextern.h"
34 #include "intervals.h"
36 Lisp_Object Vstandard_output
, Qstandard_output
;
38 Lisp_Object Qtemp_buffer_setup_hook
;
40 /* These are used to print like we read. */
41 extern Lisp_Object Qbackquote
, Qcomma
, Qcomma_at
, Qcomma_dot
, Qfunction
;
43 Lisp_Object Vfloat_output_format
, Qfloat_output_format
;
45 /* Work around a problem that happens because math.h on hpux 7
46 defines two static variables--which, in Emacs, are not really static,
47 because `static' is defined as nothing. The problem is that they are
48 defined both here and in lread.c.
49 These macros prevent the name conflict. */
50 #if defined (HPUX) && !defined (HPUX8)
51 #define _MAXLDBL print_maxldbl
52 #define _NMAXLDBL print_nmaxldbl
61 /* Default to values appropriate for IEEE floating point. */
66 #define DBL_MANT_DIG 53
72 #define DBL_MIN 2.2250738585072014e-308
75 #ifdef DBL_MIN_REPLACEMENT
77 #define DBL_MIN DBL_MIN_REPLACEMENT
80 /* Define DOUBLE_DIGITS_BOUND, an upper bound on the number of decimal digits
81 needed to express a float without losing information.
82 The general-case formula is valid for the usual case, IEEE floating point,
83 but many compilers can't optimize the formula to an integer constant,
84 so make a special case for it. */
85 #if FLT_RADIX == 2 && DBL_MANT_DIG == 53
86 #define DOUBLE_DIGITS_BOUND 17 /* IEEE floating point */
88 #define DOUBLE_DIGITS_BOUND ((int) ceil (log10 (pow (FLT_RADIX, DBL_MANT_DIG))))
91 /* Avoid actual stack overflow in print. */
94 /* Nonzero if inside outputting backquote in old style. */
95 int old_backquote_output
;
97 /* Detect most circularities to print finite output. */
98 #define PRINT_CIRCLE 200
99 Lisp_Object being_printed
[PRINT_CIRCLE
];
101 /* When printing into a buffer, first we put the text in this
102 block, then insert it all at once. */
105 /* Size allocated in print_buffer. */
106 int print_buffer_size
;
107 /* Chars stored in print_buffer. */
108 int print_buffer_pos
;
109 /* Bytes stored in print_buffer. */
110 int print_buffer_pos_byte
;
112 /* Maximum length of list to print in full; noninteger means
113 effectively infinity */
115 Lisp_Object Vprint_length
;
117 /* Maximum depth of list to print in full; noninteger means
118 effectively infinity. */
120 Lisp_Object Vprint_level
;
122 /* Nonzero means print newlines in strings as \n. */
124 int print_escape_newlines
;
126 /* Nonzero means to print single-byte non-ascii characters in strings as
129 int print_escape_nonascii
;
131 /* Nonzero means to print multibyte characters in strings as hex escapes. */
133 int print_escape_multibyte
;
135 Lisp_Object Qprint_escape_newlines
;
136 Lisp_Object Qprint_escape_multibyte
, Qprint_escape_nonascii
;
138 /* Nonzero means print (quote foo) forms as 'foo, etc. */
142 /* Non-nil means print #: before uninterned symbols. */
144 Lisp_Object Vprint_gensym
;
146 /* Non-nil means print recursive structures using #n= and #n# syntax. */
148 Lisp_Object Vprint_circle
;
150 /* Non-nil means keep continuous number for #n= and #n# syntax
151 between several print functions. */
153 Lisp_Object Vprint_continuous_numbering
;
155 /* Vprint_number_table is a vector like [OBJ1 STAT1 OBJ2 STAT2 ...],
156 where OBJn are objects going to be printed, and STATn are their status,
157 which may be different meanings during process. See the comments of
158 the functions print and print_preprocess for details.
159 print_number_index keeps the last position the next object should be added,
160 twice of which is the actual vector position in Vprint_number_table. */
161 int print_number_index
;
162 Lisp_Object Vprint_number_table
;
164 /* PRINT_NUMBER_OBJECT returns the I'th object in Vprint_number_table TABLE.
165 PRINT_NUMBER_STATUS returns the status of the I'th object in TABLE.
166 See the comment of the variable Vprint_number_table. */
167 #define PRINT_NUMBER_OBJECT(table,i) XVECTOR ((table))->contents[(i) * 2]
168 #define PRINT_NUMBER_STATUS(table,i) XVECTOR ((table))->contents[(i) * 2 + 1]
170 /* Nonzero means print newline to stdout before next minibuffer message.
171 Defined in xdisp.c */
173 extern int noninteractive_need_newline
;
175 extern int minibuffer_auto_raise
;
177 #ifdef MAX_PRINT_CHARS
178 static int print_chars
;
179 static int max_print
;
180 #endif /* MAX_PRINT_CHARS */
182 void print_interval ();
185 /* Low level output routines for characters and strings */
187 /* Lisp functions to do output using a stream
188 must have the stream in a variable called printcharfun
189 and must start with PRINTPREPARE, end with PRINTFINISH,
190 and use PRINTDECLARE to declare common variables.
191 Use PRINTCHAR to output one character,
192 or call strout to output a block of characters. */
194 #define PRINTDECLARE \
195 struct buffer *old = current_buffer; \
196 int old_point = -1, start_point = -1; \
197 int old_point_byte = -1, start_point_byte = -1; \
198 int specpdl_count = SPECPDL_INDEX (); \
199 int free_print_buffer = 0; \
200 int multibyte = !NILP (current_buffer->enable_multibyte_characters); \
203 #define PRINTPREPARE \
204 original = printcharfun; \
205 if (NILP (printcharfun)) printcharfun = Qt; \
206 if (BUFFERP (printcharfun)) \
208 if (XBUFFER (printcharfun) != current_buffer) \
209 Fset_buffer (printcharfun); \
210 printcharfun = Qnil; \
212 if (MARKERP (printcharfun)) \
214 if (!(XMARKER (original)->buffer)) \
215 error ("Marker does not point anywhere"); \
216 if (XMARKER (original)->buffer != current_buffer) \
217 set_buffer_internal (XMARKER (original)->buffer); \
219 old_point_byte = PT_BYTE; \
220 SET_PT_BOTH (marker_position (printcharfun), \
221 marker_byte_position (printcharfun)); \
223 start_point_byte = PT_BYTE; \
224 printcharfun = Qnil; \
226 if (NILP (printcharfun)) \
228 Lisp_Object string; \
229 if (NILP (current_buffer->enable_multibyte_characters) \
230 && ! print_escape_multibyte) \
231 specbind (Qprint_escape_multibyte, Qt); \
232 if (! NILP (current_buffer->enable_multibyte_characters) \
233 && ! print_escape_nonascii) \
234 specbind (Qprint_escape_nonascii, Qt); \
235 if (print_buffer != 0) \
237 string = make_string_from_bytes (print_buffer, \
239 print_buffer_pos_byte); \
240 record_unwind_protect (print_unwind, string); \
244 print_buffer_size = 1000; \
245 print_buffer = (char *) xmalloc (print_buffer_size); \
246 free_print_buffer = 1; \
248 print_buffer_pos = 0; \
249 print_buffer_pos_byte = 0; \
251 if (EQ (printcharfun, Qt) && ! noninteractive) \
252 setup_echo_area_for_printing (multibyte);
254 #define PRINTFINISH \
255 if (NILP (printcharfun)) \
257 if (print_buffer_pos != print_buffer_pos_byte \
258 && NILP (current_buffer->enable_multibyte_characters)) \
260 unsigned char *temp \
261 = (unsigned char *) alloca (print_buffer_pos + 1); \
262 copy_text (print_buffer, temp, print_buffer_pos_byte, \
264 insert_1_both (temp, print_buffer_pos, \
265 print_buffer_pos, 0, 1, 0); \
268 insert_1_both (print_buffer, print_buffer_pos, \
269 print_buffer_pos_byte, 0, 1, 0); \
271 if (free_print_buffer) \
273 xfree (print_buffer); \
276 unbind_to (specpdl_count, Qnil); \
277 if (MARKERP (original)) \
278 set_marker_both (original, Qnil, PT, PT_BYTE); \
279 if (old_point >= 0) \
280 SET_PT_BOTH (old_point + (old_point >= start_point \
281 ? PT - start_point : 0), \
282 old_point_byte + (old_point_byte >= start_point_byte \
283 ? PT_BYTE - start_point_byte : 0)); \
284 if (old != current_buffer) \
285 set_buffer_internal (old);
287 #define PRINTCHAR(ch) printchar (ch, printcharfun)
289 /* This is used to restore the saved contents of print_buffer
290 when there is a recursive call to print. */
293 print_unwind (saved_text
)
294 Lisp_Object saved_text
;
296 bcopy (SDATA (saved_text
), print_buffer
, SCHARS (saved_text
));
301 /* Print character CH using method FUN. FUN nil means print to
302 print_buffer. FUN t means print to echo area or stdout if
303 non-interactive. If FUN is neither nil nor t, call FUN with CH as
311 #ifdef MAX_PRINT_CHARS
314 #endif /* MAX_PRINT_CHARS */
316 if (!NILP (fun
) && !EQ (fun
, Qt
))
317 call1 (fun
, make_number (ch
));
320 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
321 int len
= CHAR_STRING (ch
, str
);
327 if (print_buffer_pos_byte
+ len
>= print_buffer_size
)
328 print_buffer
= (char *) xrealloc (print_buffer
,
329 print_buffer_size
*= 2);
330 bcopy (str
, print_buffer
+ print_buffer_pos_byte
, len
);
331 print_buffer_pos
+= 1;
332 print_buffer_pos_byte
+= len
;
334 else if (noninteractive
)
336 fwrite (str
, 1, len
, stdout
);
337 noninteractive_need_newline
= 1;
342 = !NILP (current_buffer
->enable_multibyte_characters
);
344 setup_echo_area_for_printing (multibyte_p
);
346 message_dolog (str
, len
, 0, multibyte_p
);
352 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
353 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
354 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
355 print_buffer. PRINTCHARFUN t means output to the echo area or to
356 stdout if non-interactive. If neither nil nor t, call Lisp
357 function PRINTCHARFUN for each character printed. MULTIBYTE
358 non-zero means PTR contains multibyte characters. */
361 strout (ptr
, size
, size_byte
, printcharfun
, multibyte
)
364 Lisp_Object printcharfun
;
368 size_byte
= size
= strlen (ptr
);
370 if (NILP (printcharfun
))
372 if (print_buffer_pos_byte
+ size_byte
> print_buffer_size
)
374 print_buffer_size
= print_buffer_size
* 2 + size_byte
;
375 print_buffer
= (char *) xrealloc (print_buffer
,
378 bcopy (ptr
, print_buffer
+ print_buffer_pos_byte
, size_byte
);
379 print_buffer_pos
+= size
;
380 print_buffer_pos_byte
+= size_byte
;
382 #ifdef MAX_PRINT_CHARS
385 #endif /* MAX_PRINT_CHARS */
387 else if (noninteractive
&& EQ (printcharfun
, Qt
))
389 fwrite (ptr
, 1, size_byte
, stdout
);
390 noninteractive_need_newline
= 1;
392 else if (EQ (printcharfun
, Qt
))
394 /* Output to echo area. We're trying to avoid a little overhead
395 here, that's the reason we don't call printchar to do the
399 = !NILP (current_buffer
->enable_multibyte_characters
);
401 setup_echo_area_for_printing (multibyte_p
);
402 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
404 if (size
== size_byte
)
406 for (i
= 0; i
< size
; ++i
)
407 insert_char ((unsigned char )*ptr
++);
412 for (i
= 0; i
< size_byte
; i
+= len
)
414 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size_byte
- i
, len
);
419 #ifdef MAX_PRINT_CHARS
422 #endif /* MAX_PRINT_CHARS */
426 /* PRINTCHARFUN is a Lisp function. */
429 if (size
== size_byte
)
431 while (i
< size_byte
)
439 while (i
< size_byte
)
441 /* Here, we must convert each multi-byte form to the
442 corresponding character code before handing it to
445 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size_byte
- i
, len
);
453 /* Print the contents of a string STRING using PRINTCHARFUN.
454 It isn't safe to use strout in many cases,
455 because printing one char can relocate. */
458 print_string (string
, printcharfun
)
460 Lisp_Object printcharfun
;
462 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
466 if (STRING_MULTIBYTE (string
))
467 chars
= SCHARS (string
);
468 else if (EQ (printcharfun
, Qt
)
469 ? ! NILP (buffer_defaults
.enable_multibyte_characters
)
470 : ! NILP (current_buffer
->enable_multibyte_characters
))
472 /* If unibyte string STRING contains 8-bit codes, we must
473 convert STRING to a multibyte string containing the same
478 chars
= SBYTES (string
);
479 bytes
= parse_str_to_multibyte (SDATA (string
), chars
);
482 newstr
= make_uninit_multibyte_string (chars
, bytes
);
483 bcopy (SDATA (string
), SDATA (newstr
), chars
);
484 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
489 chars
= SBYTES (string
);
491 /* strout is safe for output to a frame (echo area) or to print_buffer. */
492 strout (SDATA (string
),
493 chars
, SBYTES (string
),
494 printcharfun
, STRING_MULTIBYTE (string
));
498 /* Otherwise, string may be relocated by printing one char.
499 So re-fetch the string address for each character. */
501 int size
= SCHARS (string
);
502 int size_byte
= SBYTES (string
);
505 if (size
== size_byte
)
506 for (i
= 0; i
< size
; i
++)
507 PRINTCHAR (SREF (string
, i
));
509 for (i
= 0; i
< size_byte
; )
511 /* Here, we must convert each multi-byte form to the
512 corresponding character code before handing it to PRINTCHAR. */
514 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
,
516 if (!CHAR_VALID_P (ch
, 0))
518 ch
= SREF (string
, i
);
528 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
529 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
530 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
531 (character
, printcharfun
)
532 Lisp_Object character
, printcharfun
;
536 if (NILP (printcharfun
))
537 printcharfun
= Vstandard_output
;
538 CHECK_NUMBER (character
);
540 PRINTCHAR (XINT (character
));
545 /* Used from outside of print.c to print a block of SIZE
546 single-byte chars at DATA on the default output stream.
547 Do not use this on the contents of a Lisp string. */
550 write_string (data
, size
)
555 Lisp_Object printcharfun
;
557 printcharfun
= Vstandard_output
;
560 strout (data
, size
, size
, printcharfun
, 0);
564 /* Used from outside of print.c to print a block of SIZE
565 single-byte chars at DATA on a specified stream PRINTCHARFUN.
566 Do not use this on the contents of a Lisp string. */
569 write_string_1 (data
, size
, printcharfun
)
572 Lisp_Object printcharfun
;
577 strout (data
, size
, size
, printcharfun
, 0);
583 temp_output_buffer_setup (bufname
)
586 int count
= SPECPDL_INDEX ();
587 register struct buffer
*old
= current_buffer
;
588 register Lisp_Object buf
;
590 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
592 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
594 Fkill_all_local_variables ();
595 delete_all_overlays (current_buffer
);
596 current_buffer
->directory
= old
->directory
;
597 current_buffer
->read_only
= Qnil
;
598 current_buffer
->filename
= Qnil
;
599 current_buffer
->undo_list
= Qt
;
600 eassert (current_buffer
->overlays_before
== NULL
);
601 eassert (current_buffer
->overlays_after
== NULL
);
602 current_buffer
->enable_multibyte_characters
603 = buffer_defaults
.enable_multibyte_characters
;
605 XSETBUFFER (buf
, current_buffer
);
607 Frun_hooks (1, &Qtemp_buffer_setup_hook
);
609 unbind_to (count
, Qnil
);
611 specbind (Qstandard_output
, buf
);
615 internal_with_output_to_temp_buffer (bufname
, function
, args
)
617 Lisp_Object (*function
) P_ ((Lisp_Object
));
620 int count
= SPECPDL_INDEX ();
621 Lisp_Object buf
, val
;
625 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
626 temp_output_buffer_setup (bufname
);
627 buf
= Vstandard_output
;
630 val
= (*function
) (args
);
633 temp_output_buffer_show (buf
);
636 return unbind_to (count
, val
);
639 DEFUN ("with-output-to-temp-buffer",
640 Fwith_output_to_temp_buffer
, Swith_output_to_temp_buffer
,
642 doc
: /* Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
643 The buffer is cleared out initially, and marked as unmodified when done.
644 All output done by BODY is inserted in that buffer by default.
645 The buffer is displayed in another window, but not selected.
646 The value of the last form in BODY is returned.
647 If BODY does not finish normally, the buffer BUFNAME is not displayed.
649 The hook `temp-buffer-setup-hook' is run before BODY,
650 with the buffer BUFNAME temporarily current.
651 The hook `temp-buffer-show-hook' is run after the buffer is displayed,
652 with the buffer temporarily current, and the window that was used
653 to display it temporarily selected.
655 If variable `temp-buffer-show-function' is non-nil, call it at the end
656 to get the buffer displayed instead of just displaying the non-selected
657 buffer and calling the hook. It gets one argument, the buffer to display.
659 usage: (with-output-to-temp-buffer BUFFNAME BODY ...) */)
665 int count
= SPECPDL_INDEX ();
666 Lisp_Object buf
, val
;
669 name
= Feval (Fcar (args
));
671 temp_output_buffer_setup (SDATA (name
));
672 buf
= Vstandard_output
;
675 val
= Fprogn (XCDR (args
));
678 temp_output_buffer_show (buf
);
681 return unbind_to (count
, val
);
685 static void print ();
686 static void print_preprocess ();
687 static void print_preprocess_string ();
688 static void print_object ();
690 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
691 doc
: /* Output a newline to stream PRINTCHARFUN.
692 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
694 Lisp_Object printcharfun
;
698 if (NILP (printcharfun
))
699 printcharfun
= Vstandard_output
;
706 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
707 doc
: /* Output the printed representation of OBJECT, any Lisp object.
708 Quoting characters are printed when needed to make output that `read'
709 can handle, whenever this is possible. For complex objects, the behavior
710 is controlled by `print-level' and `print-length', which see.
712 OBJECT is any of the Lisp data types: a number, a string, a symbol,
713 a list, a buffer, a window, a frame, etc.
715 A printed representation of an object is text which describes that object.
717 Optional argument PRINTCHARFUN is the output stream, which can be one
720 - a buffer, in which case output is inserted into that buffer at point;
721 - a marker, in which case output is inserted at marker's position;
722 - a function, in which case that function is called once for each
723 character of OBJECT's printed representation;
724 - a symbol, in which case that symbol's function definition is called; or
725 - t, in which case the output is displayed in the echo area.
727 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
729 (object
, printcharfun
)
730 Lisp_Object object
, printcharfun
;
734 #ifdef MAX_PRINT_CHARS
736 #endif /* MAX_PRINT_CHARS */
737 if (NILP (printcharfun
))
738 printcharfun
= Vstandard_output
;
740 print (object
, printcharfun
, 1);
745 /* a buffer which is used to hold output being built by prin1-to-string */
746 Lisp_Object Vprin1_to_string_buffer
;
748 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
749 doc
: /* Return a string containing the printed representation of OBJECT.
750 OBJECT can be any Lisp object. This function outputs quoting characters
751 when necessary to make output that `read' can handle, whenever possible,
752 unless the optional second argument NOESCAPE is non-nil.
754 OBJECT is any of the Lisp data types: a number, a string, a symbol,
755 a list, a buffer, a window, a frame, etc.
757 A printed representation of an object is text which describes that object. */)
759 Lisp_Object object
, noescape
;
762 Lisp_Object printcharfun
;
763 /* struct gcpro gcpro1, gcpro2; */
764 Lisp_Object save_deactivate_mark
;
765 int count
= specpdl_ptr
- specpdl
;
767 specbind (Qinhibit_modification_hooks
, Qt
);
769 /* Save and restore this--we are altering a buffer
770 but we don't want to deactivate the mark just for that.
771 No need for specbind, since errors deactivate the mark. */
772 save_deactivate_mark
= Vdeactivate_mark
;
773 /* GCPRO2 (object, save_deactivate_mark); */
776 printcharfun
= Vprin1_to_string_buffer
;
778 print (object
, printcharfun
, NILP (noescape
));
779 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
781 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
782 object
= Fbuffer_string ();
783 if (SBYTES (object
) == SCHARS (object
))
784 STRING_SET_UNIBYTE (object
);
787 set_buffer_internal (old
);
789 Vdeactivate_mark
= save_deactivate_mark
;
793 return unbind_to (count
, object
);
796 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
797 doc
: /* Output the printed representation of OBJECT, any Lisp object.
798 No quoting characters are used; no delimiters are printed around
799 the contents of strings.
801 OBJECT is any of the Lisp data types: a number, a string, a symbol,
802 a list, a buffer, a window, a frame, etc.
804 A printed representation of an object is text which describes that object.
806 Optional argument PRINTCHARFUN is the output stream, which can be one
809 - a buffer, in which case output is inserted into that buffer at point;
810 - a marker, in which case output is inserted at marker's position;
811 - a function, in which case that function is called once for each
812 character of OBJECT's printed representation;
813 - a symbol, in which case that symbol's function definition is called; or
814 - t, in which case the output is displayed in the echo area.
816 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
818 (object
, printcharfun
)
819 Lisp_Object object
, printcharfun
;
823 if (NILP (printcharfun
))
824 printcharfun
= Vstandard_output
;
826 print (object
, printcharfun
, 0);
831 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
832 doc
: /* Output the printed representation of OBJECT, with newlines around it.
833 Quoting characters are printed when needed to make output that `read'
834 can handle, whenever this is possible. For complex objects, the behavior
835 is controlled by `print-level' and `print-length', which see.
837 OBJECT is any of the Lisp data types: a number, a string, a symbol,
838 a list, a buffer, a window, a frame, etc.
840 A printed representation of an object is text which describes that object.
842 Optional argument PRINTCHARFUN is the output stream, which can be one
845 - a buffer, in which case output is inserted into that buffer at point;
846 - a marker, in which case output is inserted at marker's position;
847 - a function, in which case that function is called once for each
848 character of OBJECT's printed representation;
849 - a symbol, in which case that symbol's function definition is called; or
850 - t, in which case the output is displayed in the echo area.
852 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
854 (object
, printcharfun
)
855 Lisp_Object object
, printcharfun
;
860 #ifdef MAX_PRINT_CHARS
862 max_print
= MAX_PRINT_CHARS
;
863 #endif /* MAX_PRINT_CHARS */
864 if (NILP (printcharfun
))
865 printcharfun
= Vstandard_output
;
869 print (object
, printcharfun
, 1);
872 #ifdef MAX_PRINT_CHARS
875 #endif /* MAX_PRINT_CHARS */
880 /* The subroutine object for external-debugging-output is kept here
881 for the convenience of the debugger. */
882 Lisp_Object Qexternal_debugging_output
;
884 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
885 doc
: /* Write CHARACTER to stderr.
886 You can call print while debugging emacs, and pass it this function
887 to make it write to the debugging output. */)
889 Lisp_Object character
;
891 CHECK_NUMBER (character
);
892 putc (XINT (character
), stderr
);
895 /* Send the output to a debugger (nothing happens if there isn't one). */
897 char buf
[2] = {(char) XINT (character
), '\0'};
898 OutputDebugString (buf
);
905 /* This is the interface for debugging printing. */
911 Fprin1 (arg
, Qexternal_debugging_output
);
912 fprintf (stderr
, "\r\n");
915 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
917 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message. */)
921 struct buffer
*old
= current_buffer
;
925 /* If OBJ is (error STRING), just return STRING.
926 That is not only faster, it also avoids the need to allocate
927 space here when the error is due to memory full. */
928 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
929 && CONSP (XCDR (obj
))
930 && STRINGP (XCAR (XCDR (obj
)))
931 && NILP (XCDR (XCDR (obj
))))
932 return XCAR (XCDR (obj
));
934 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
936 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
937 value
= Fbuffer_string ();
941 set_buffer_internal (old
);
947 /* Print an error message for the error DATA onto Lisp output stream
948 STREAM (suitable for the print functions). */
951 print_error_message (data
, stream
, context
, caller
)
952 Lisp_Object data
, stream
;
956 Lisp_Object errname
, errmsg
, file_error
, tail
;
961 write_string_1 (context
, -1, stream
);
963 /* If we know from where the error was signaled, show it in
965 if (!NILP (caller
) && SYMBOLP (caller
))
967 const char *name
= SDATA (SYMBOL_NAME (caller
));
968 message_dolog (name
, strlen (name
), 0, 0);
969 message_dolog (": ", 2, 0, 0);
972 errname
= Fcar (data
);
974 if (EQ (errname
, Qerror
))
979 errmsg
= Fcar (data
);
984 Lisp_Object error_conditions
;
985 errmsg
= Fget (errname
, Qerror_message
);
986 error_conditions
= Fget (errname
, Qerror_conditions
);
987 file_error
= Fmemq (Qfile_error
, error_conditions
);
990 /* Print an error message including the data items. */
992 tail
= Fcdr_safe (data
);
995 /* For file-error, make error message by concatenating
996 all the data items. They are all strings. */
997 if (!NILP (file_error
) && CONSP (tail
))
998 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
1000 if (STRINGP (errmsg
))
1001 Fprinc (errmsg
, stream
);
1003 write_string_1 ("peculiar error", -1, stream
);
1005 for (i
= 0; CONSP (tail
); tail
= XCDR (tail
), i
++)
1009 write_string_1 (i
? ", " : ": ", 2, stream
);
1011 if (!NILP (file_error
) || EQ (errname
, Qend_of_file
))
1012 Fprinc (obj
, stream
);
1014 Fprin1 (obj
, stream
);
1023 * The buffer should be at least as large as the max string size of the
1024 * largest float, printed in the biggest notation. This is undoubtedly
1025 * 20d float_output_format, with the negative of the C-constant "HUGE"
1028 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
1030 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
1031 * case of -1e307 in 20d float_output_format. What is one to do (short of
1032 * re-writing _doprnt to be more sane)?
1037 float_to_string (buf
, data
)
1044 /* Check for plus infinity in a way that won't lose
1045 if there is no plus infinity. */
1046 if (data
== data
/ 2 && data
> 1.0)
1048 strcpy (buf
, "1.0e+INF");
1051 /* Likewise for minus infinity. */
1052 if (data
== data
/ 2 && data
< -1.0)
1054 strcpy (buf
, "-1.0e+INF");
1057 /* Check for NaN in a way that won't fail if there are no NaNs. */
1058 if (! (data
* 0.0 >= 0.0))
1060 /* Prepend "-" if the NaN's sign bit is negative.
1061 The sign bit of a double is the bit that is 1 in -0.0. */
1063 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
1065 u_minus_zero
.d
= - 0.0;
1066 for (i
= 0; i
< sizeof (double); i
++)
1067 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
1073 strcpy (buf
, "0.0e+NaN");
1077 if (NILP (Vfloat_output_format
)
1078 || !STRINGP (Vfloat_output_format
))
1081 /* Generate the fewest number of digits that represent the
1082 floating point value without losing information.
1083 The following method is simple but a bit slow.
1084 For ideas about speeding things up, please see:
1086 Guy L Steele Jr & Jon L White, How to print floating-point numbers
1087 accurately. SIGPLAN notices 25, 6 (June 1990), 112-126.
1089 Robert G Burger & R Kent Dybvig, Printing floating point numbers
1090 quickly and accurately, SIGPLAN notices 31, 5 (May 1996), 108-116. */
1092 width
= fabs (data
) < DBL_MIN
? 1 : DBL_DIG
;
1094 sprintf (buf
, "%.*g", width
, data
);
1095 while (width
++ < DOUBLE_DIGITS_BOUND
&& atof (buf
) != data
);
1097 else /* oink oink */
1099 /* Check that the spec we have is fully valid.
1100 This means not only valid for printf,
1101 but meant for floats, and reasonable. */
1102 cp
= SDATA (Vfloat_output_format
);
1111 /* Check the width specification. */
1113 if ('0' <= *cp
&& *cp
<= '9')
1117 width
= (width
* 10) + (*cp
++ - '0');
1118 while (*cp
>= '0' && *cp
<= '9');
1120 /* A precision of zero is valid only for %f. */
1122 || (width
== 0 && *cp
!= 'f'))
1126 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1132 sprintf (buf
, SDATA (Vfloat_output_format
), data
);
1135 /* Make sure there is a decimal point with digit after, or an
1136 exponent, so that the value is readable as a float. But don't do
1137 this with "%.0f"; it's valid for that not to produce a decimal
1138 point. Note that width can be 0 only for %.0f. */
1141 for (cp
= buf
; *cp
; cp
++)
1142 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1145 if (*cp
== '.' && cp
[1] == 0)
1162 print (obj
, printcharfun
, escapeflag
)
1164 register Lisp_Object printcharfun
;
1168 old_backquote_output
= 0;
1170 /* Reset print_number_index and Vprint_number_table only when
1171 the variable Vprint_continuous_numbering is nil. Otherwise,
1172 the values of these variables will be kept between several
1174 if (NILP (Vprint_continuous_numbering
))
1176 print_number_index
= 0;
1177 Vprint_number_table
= Qnil
;
1180 /* Construct Vprint_number_table for print-gensym and print-circle. */
1181 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1183 int i
, start
, index
;
1184 start
= index
= print_number_index
;
1185 /* Construct Vprint_number_table.
1186 This increments print_number_index for the objects added. */
1187 print_preprocess (obj
);
1189 /* Remove unnecessary objects, which appear only once in OBJ;
1190 that is, whose status is Qnil. Compactify the necessary objects. */
1191 for (i
= start
; i
< print_number_index
; i
++)
1192 if (!NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1194 PRINT_NUMBER_OBJECT (Vprint_number_table
, index
)
1195 = PRINT_NUMBER_OBJECT (Vprint_number_table
, i
);
1199 /* Clear out objects outside the active part of the table. */
1200 for (i
= index
; i
< print_number_index
; i
++)
1201 PRINT_NUMBER_OBJECT (Vprint_number_table
, i
) = Qnil
;
1203 /* Reset the status field for the next print step. Now this
1204 field means whether the object has already been printed. */
1205 for (i
= start
; i
< print_number_index
; i
++)
1206 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qnil
;
1208 print_number_index
= index
;
1211 print_object (obj
, printcharfun
, escapeflag
);
1214 /* Construct Vprint_number_table according to the structure of OBJ.
1215 OBJ itself and all its elements will be added to Vprint_number_table
1216 recursively if it is a list, vector, compiled function, char-table,
1217 string (its text properties will be traced), or a symbol that has
1218 no obarray (this is for the print-gensym feature).
1219 The status fields of Vprint_number_table mean whether each object appears
1220 more than once in OBJ: Qnil at the first time, and Qt after that . */
1222 print_preprocess (obj
)
1228 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1229 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
)
1230 || (! NILP (Vprint_gensym
)
1232 && !SYMBOL_INTERNED_P (obj
)))
1234 /* In case print-circle is nil and print-gensym is t,
1235 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1236 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1238 for (i
= 0; i
< print_number_index
; i
++)
1239 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
), obj
))
1241 /* OBJ appears more than once. Let's remember that. */
1242 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1246 /* OBJ is not yet recorded. Let's add to the table. */
1247 if (print_number_index
== 0)
1249 /* Initialize the table. */
1250 Vprint_number_table
= Fmake_vector (make_number (40), Qnil
);
1252 else if (XVECTOR (Vprint_number_table
)->size
== print_number_index
* 2)
1254 /* Reallocate the table. */
1255 int i
= print_number_index
* 4;
1256 Lisp_Object old_table
= Vprint_number_table
;
1257 Vprint_number_table
= Fmake_vector (make_number (i
), Qnil
);
1258 for (i
= 0; i
< print_number_index
; i
++)
1260 PRINT_NUMBER_OBJECT (Vprint_number_table
, i
)
1261 = PRINT_NUMBER_OBJECT (old_table
, i
);
1262 PRINT_NUMBER_STATUS (Vprint_number_table
, i
)
1263 = PRINT_NUMBER_STATUS (old_table
, i
);
1266 PRINT_NUMBER_OBJECT (Vprint_number_table
, print_number_index
) = obj
;
1267 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1268 always print the gensym with a number. This is a special for
1269 the lisp function byte-compile-output-docform. */
1270 if (!NILP (Vprint_continuous_numbering
)
1272 && !SYMBOL_INTERNED_P (obj
))
1273 PRINT_NUMBER_STATUS (Vprint_number_table
, print_number_index
) = Qt
;
1274 print_number_index
++;
1277 switch (XGCTYPE (obj
))
1280 /* A string may have text properties, which can be circular. */
1281 traverse_intervals_noorder (STRING_INTERVALS (obj
),
1282 print_preprocess_string
, Qnil
);
1286 print_preprocess (XCAR (obj
));
1290 case Lisp_Vectorlike
:
1291 size
= XVECTOR (obj
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1292 for (i
= 0; i
< size
; i
++)
1293 print_preprocess (XVECTOR (obj
)->contents
[i
]);
1303 print_preprocess_string (interval
, arg
)
1307 print_preprocess (interval
->plist
);
1311 print_object (obj
, printcharfun
, escapeflag
)
1313 register Lisp_Object printcharfun
;
1320 /* Detect circularities and truncate them. */
1321 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1322 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
)
1323 || (! NILP (Vprint_gensym
)
1325 && !SYMBOL_INTERNED_P (obj
)))
1327 if (NILP (Vprint_circle
) && NILP (Vprint_gensym
))
1329 /* Simple but incomplete way. */
1331 for (i
= 0; i
< print_depth
; i
++)
1332 if (EQ (obj
, being_printed
[i
]))
1334 sprintf (buf
, "#%d", i
);
1335 strout (buf
, -1, -1, printcharfun
, 0);
1338 being_printed
[print_depth
] = obj
;
1342 /* With the print-circle feature. */
1344 for (i
= 0; i
< print_number_index
; i
++)
1345 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
), obj
))
1347 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1349 /* Add a prefix #n= if OBJ has not yet been printed;
1350 that is, its status field is nil. */
1351 sprintf (buf
, "#%d=", i
+ 1);
1352 strout (buf
, -1, -1, printcharfun
, 0);
1353 /* OBJ is going to be printed. Set the status to t. */
1354 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1359 /* Just print #n# if OBJ has already been printed. */
1360 sprintf (buf
, "#%d#", i
+ 1);
1361 strout (buf
, -1, -1, printcharfun
, 0);
1370 if (print_depth
> PRINT_CIRCLE
)
1371 error ("Apparently circular structure being printed");
1372 #ifdef MAX_PRINT_CHARS
1373 if (max_print
&& print_chars
> max_print
)
1378 #endif /* MAX_PRINT_CHARS */
1380 switch (XGCTYPE (obj
))
1383 if (sizeof (int) == sizeof (EMACS_INT
))
1384 sprintf (buf
, "%d", XINT (obj
));
1385 else if (sizeof (long) == sizeof (EMACS_INT
))
1386 sprintf (buf
, "%ld", (long) XINT (obj
));
1389 strout (buf
, -1, -1, printcharfun
, 0);
1394 char pigbuf
[350]; /* see comments in float_to_string */
1396 float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1397 strout (pigbuf
, -1, -1, printcharfun
, 0);
1403 print_string (obj
, printcharfun
);
1406 register int i
, i_byte
;
1407 struct gcpro gcpro1
;
1410 /* 1 means we must ensure that the next character we output
1411 cannot be taken as part of a hex character escape. */
1412 int need_nonhex
= 0;
1413 int multibyte
= STRING_MULTIBYTE (obj
);
1417 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1425 size_byte
= SBYTES (obj
);
1427 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1429 /* Here, we must convert each multi-byte form to the
1430 corresponding character code before handing it to PRINTCHAR. */
1436 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
,
1437 size_byte
- i_byte
, len
);
1438 if (CHAR_VALID_P (c
, 0))
1448 if (c
== '\n' && print_escape_newlines
)
1453 else if (c
== '\f' && print_escape_newlines
)
1459 && ! ASCII_BYTE_P (c
)
1460 && (SINGLE_BYTE_CHAR_P (c
) || print_escape_multibyte
))
1462 /* When multibyte is disabled,
1463 print multibyte string chars using hex escapes.
1464 For a char code that could be in a unibyte string,
1465 when found in a multibyte string, always use a hex escape
1466 so it reads back as multibyte. */
1467 unsigned char outbuf
[50];
1468 sprintf (outbuf
, "\\x%x", c
);
1469 strout (outbuf
, -1, -1, printcharfun
, 0);
1472 else if (! multibyte
1473 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1474 && print_escape_nonascii
)
1476 /* When printing in a multibyte buffer
1477 or when explicitly requested,
1478 print single-byte non-ASCII string chars
1479 using octal escapes. */
1480 unsigned char outbuf
[5];
1481 sprintf (outbuf
, "\\%03o", c
);
1482 strout (outbuf
, -1, -1, printcharfun
, 0);
1486 /* If we just had a hex escape, and this character
1487 could be taken as part of it,
1488 output `\ ' to prevent that. */
1492 if ((c
>= 'a' && c
<= 'f')
1493 || (c
>= 'A' && c
<= 'F')
1494 || (c
>= '0' && c
<= '9'))
1495 strout ("\\ ", -1, -1, printcharfun
, 0);
1498 if (c
== '\"' || c
== '\\')
1505 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1507 traverse_intervals (STRING_INTERVALS (obj
),
1508 0, print_interval
, printcharfun
);
1518 register int confusing
;
1519 register unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1520 register unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1522 int i
, i_byte
, size_byte
;
1525 name
= SYMBOL_NAME (obj
);
1527 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1530 /* If symbol name begins with a digit, and ends with a digit,
1531 and contains nothing but digits and `e', it could be treated
1532 as a number. So set CONFUSING.
1534 Symbols that contain periods could also be taken as numbers,
1535 but periods are always escaped, so we don't have to worry
1537 else if (*p
>= '0' && *p
<= '9'
1538 && end
[-1] >= '0' && end
[-1] <= '9')
1540 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1541 /* Needed for \2e10. */
1544 confusing
= (end
== p
);
1549 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1555 size_byte
= SBYTES (name
);
1557 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1559 /* Here, we must convert each multi-byte form to the
1560 corresponding character code before handing it to PRINTCHAR. */
1561 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1566 if (c
== '\"' || c
== '\\' || c
== '\''
1567 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1568 || c
== ',' || c
=='.' || c
== '`'
1569 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1571 PRINTCHAR ('\\'), confusing
= 0;
1579 /* If deeper than spec'd depth, print placeholder. */
1580 if (INTEGERP (Vprint_level
)
1581 && print_depth
> XINT (Vprint_level
))
1582 strout ("...", -1, -1, printcharfun
, 0);
1583 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1584 && (EQ (XCAR (obj
), Qquote
)))
1587 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1589 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1590 && (EQ (XCAR (obj
), Qfunction
)))
1594 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1596 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1597 && ! old_backquote_output
1598 && ((EQ (XCAR (obj
), Qbackquote
)
1599 || EQ (XCAR (obj
), Qcomma
)
1600 || EQ (XCAR (obj
), Qcomma_at
)
1601 || EQ (XCAR (obj
), Qcomma_dot
))))
1603 print_object (XCAR (obj
), printcharfun
, 0);
1604 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1610 /* If the first element is a backquote form,
1611 print it old-style so it won't be misunderstood. */
1612 if (print_quoted
&& CONSP (XCAR (obj
))
1613 && CONSP (XCDR (XCAR (obj
)))
1614 && NILP (XCDR (XCDR (XCAR (obj
))))
1615 && EQ (XCAR (XCAR (obj
)), Qbackquote
))
1621 print_object (Qbackquote
, printcharfun
, 0);
1624 ++old_backquote_output
;
1625 print_object (XCAR (XCDR (tem
)), printcharfun
, 0);
1626 --old_backquote_output
;
1633 int print_length
, i
;
1634 Lisp_Object halftail
= obj
;
1636 /* Negative values of print-length are invalid in CL.
1637 Treat them like nil, as CMUCL does. */
1638 if (NATNUMP (Vprint_length
))
1639 print_length
= XFASTINT (Vprint_length
);
1646 /* Detect circular list. */
1647 if (NILP (Vprint_circle
))
1649 /* Simple but imcomplete way. */
1650 if (i
!= 0 && EQ (obj
, halftail
))
1652 sprintf (buf
, " . #%d", i
/ 2);
1653 strout (buf
, -1, -1, printcharfun
, 0);
1659 /* With the print-circle feature. */
1663 for (i
= 0; i
< print_number_index
; i
++)
1664 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
),
1667 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1669 strout (" . ", 3, 3, printcharfun
, 0);
1670 print_object (obj
, printcharfun
, escapeflag
);
1674 sprintf (buf
, " . #%d#", i
+ 1);
1675 strout (buf
, -1, -1, printcharfun
, 0);
1685 if (print_length
&& i
> print_length
)
1687 strout ("...", 3, 3, printcharfun
, 0);
1691 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1695 halftail
= XCDR (halftail
);
1699 /* OBJ non-nil here means it's the end of a dotted list. */
1702 strout (" . ", 3, 3, printcharfun
, 0);
1703 print_object (obj
, printcharfun
, escapeflag
);
1711 case Lisp_Vectorlike
:
1716 strout ("#<process ", -1, -1, printcharfun
, 0);
1717 print_string (XPROCESS (obj
)->name
, printcharfun
);
1721 print_string (XPROCESS (obj
)->name
, printcharfun
);
1723 else if (BOOL_VECTOR_P (obj
))
1726 register unsigned char c
;
1727 struct gcpro gcpro1
;
1729 = (XBOOL_VECTOR (obj
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1735 sprintf (buf
, "%d", XBOOL_VECTOR (obj
)->size
);
1736 strout (buf
, -1, -1, printcharfun
, 0);
1739 /* Don't print more characters than the specified maximum.
1740 Negative values of print-length are invalid. Treat them
1741 like a print-length of nil. */
1742 if (NATNUMP (Vprint_length
)
1743 && XFASTINT (Vprint_length
) < size_in_chars
)
1744 size_in_chars
= XFASTINT (Vprint_length
);
1746 for (i
= 0; i
< size_in_chars
; i
++)
1749 c
= XBOOL_VECTOR (obj
)->data
[i
];
1750 if (c
== '\n' && print_escape_newlines
)
1755 else if (c
== '\f' && print_escape_newlines
)
1762 if (c
== '\"' || c
== '\\')
1771 else if (SUBRP (obj
))
1773 strout ("#<subr ", -1, -1, printcharfun
, 0);
1774 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
, 0);
1777 else if (WINDOWP (obj
))
1779 strout ("#<window ", -1, -1, printcharfun
, 0);
1780 sprintf (buf
, "%d", XFASTINT (XWINDOW (obj
)->sequence_number
));
1781 strout (buf
, -1, -1, printcharfun
, 0);
1782 if (!NILP (XWINDOW (obj
)->buffer
))
1784 strout (" on ", -1, -1, printcharfun
, 0);
1785 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1789 else if (HASH_TABLE_P (obj
))
1791 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1792 strout ("#<hash-table", -1, -1, printcharfun
, 0);
1793 if (SYMBOLP (h
->test
))
1797 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
, 0);
1799 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
, 0);
1801 sprintf (buf
, "%d/%d", XFASTINT (h
->count
),
1802 XVECTOR (h
->next
)->size
);
1803 strout (buf
, -1, -1, printcharfun
, 0);
1805 sprintf (buf
, " 0x%lx", (unsigned long) h
);
1806 strout (buf
, -1, -1, printcharfun
, 0);
1809 else if (BUFFERP (obj
))
1811 if (NILP (XBUFFER (obj
)->name
))
1812 strout ("#<killed buffer>", -1, -1, printcharfun
, 0);
1813 else if (escapeflag
)
1815 strout ("#<buffer ", -1, -1, printcharfun
, 0);
1816 print_string (XBUFFER (obj
)->name
, printcharfun
);
1820 print_string (XBUFFER (obj
)->name
, printcharfun
);
1822 else if (WINDOW_CONFIGURATIONP (obj
))
1824 strout ("#<window-configuration>", -1, -1, printcharfun
, 0);
1826 else if (FRAMEP (obj
))
1828 strout ((FRAME_LIVE_P (XFRAME (obj
))
1829 ? "#<frame " : "#<dead frame "),
1830 -1, -1, printcharfun
, 0);
1831 print_string (XFRAME (obj
)->name
, printcharfun
);
1832 sprintf (buf
, " 0x%lx", (unsigned long) (XFRAME (obj
)));
1833 strout (buf
, -1, -1, printcharfun
, 0);
1838 int size
= XVECTOR (obj
)->size
;
1839 if (COMPILEDP (obj
))
1842 size
&= PSEUDOVECTOR_SIZE_MASK
;
1844 if (CHAR_TABLE_P (obj
))
1846 /* We print a char-table as if it were a vector,
1847 lumping the parent and default slots in with the
1848 character slots. But we add #^ as a prefix. */
1851 if (SUB_CHAR_TABLE_P (obj
))
1853 size
&= PSEUDOVECTOR_SIZE_MASK
;
1855 if (size
& PSEUDOVECTOR_FLAG
)
1861 register Lisp_Object tem
;
1862 int real_size
= size
;
1864 /* Don't print more elements than the specified maximum. */
1865 if (NATNUMP (Vprint_length
)
1866 && XFASTINT (Vprint_length
) < size
)
1867 size
= XFASTINT (Vprint_length
);
1869 for (i
= 0; i
< size
; i
++)
1871 if (i
) PRINTCHAR (' ');
1872 tem
= XVECTOR (obj
)->contents
[i
];
1873 print_object (tem
, printcharfun
, escapeflag
);
1875 if (size
< real_size
)
1876 strout (" ...", 4, 4, printcharfun
, 0);
1883 switch (XMISCTYPE (obj
))
1885 case Lisp_Misc_Marker
:
1886 strout ("#<marker ", -1, -1, printcharfun
, 0);
1887 /* Do you think this is necessary? */
1888 if (XMARKER (obj
)->insertion_type
!= 0)
1889 strout ("(moves after insertion) ", -1, -1, printcharfun
, 0);
1890 if (!(XMARKER (obj
)->buffer
))
1891 strout ("in no buffer", -1, -1, printcharfun
, 0);
1894 sprintf (buf
, "at %d", marker_position (obj
));
1895 strout (buf
, -1, -1, printcharfun
, 0);
1896 strout (" in ", -1, -1, printcharfun
, 0);
1897 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
1902 case Lisp_Misc_Overlay
:
1903 strout ("#<overlay ", -1, -1, printcharfun
, 0);
1904 if (!(XMARKER (OVERLAY_START (obj
))->buffer
))
1905 strout ("in no buffer", -1, -1, printcharfun
, 0);
1908 sprintf (buf
, "from %d to %d in ",
1909 marker_position (OVERLAY_START (obj
)),
1910 marker_position (OVERLAY_END (obj
)));
1911 strout (buf
, -1, -1, printcharfun
, 0);
1912 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
1918 /* Remaining cases shouldn't happen in normal usage, but let's print
1919 them anyway for the benefit of the debugger. */
1920 case Lisp_Misc_Free
:
1921 strout ("#<misc free cell>", -1, -1, printcharfun
, 0);
1924 case Lisp_Misc_Intfwd
:
1925 sprintf (buf
, "#<intfwd to %d>", *XINTFWD (obj
)->intvar
);
1926 strout (buf
, -1, -1, printcharfun
, 0);
1929 case Lisp_Misc_Boolfwd
:
1930 sprintf (buf
, "#<boolfwd to %s>",
1931 (*XBOOLFWD (obj
)->boolvar
? "t" : "nil"));
1932 strout (buf
, -1, -1, printcharfun
, 0);
1935 case Lisp_Misc_Objfwd
:
1936 strout ("#<objfwd to ", -1, -1, printcharfun
, 0);
1937 print_object (*XOBJFWD (obj
)->objvar
, printcharfun
, escapeflag
);
1941 case Lisp_Misc_Buffer_Objfwd
:
1942 strout ("#<buffer_objfwd to ", -1, -1, printcharfun
, 0);
1943 print_object (PER_BUFFER_VALUE (current_buffer
,
1944 XBUFFER_OBJFWD (obj
)->offset
),
1945 printcharfun
, escapeflag
);
1949 case Lisp_Misc_Kboard_Objfwd
:
1950 strout ("#<kboard_objfwd to ", -1, -1, printcharfun
, 0);
1951 print_object (*(Lisp_Object
*)((char *) current_kboard
1952 + XKBOARD_OBJFWD (obj
)->offset
),
1953 printcharfun
, escapeflag
);
1957 case Lisp_Misc_Buffer_Local_Value
:
1958 strout ("#<buffer_local_value ", -1, -1, printcharfun
, 0);
1959 goto do_buffer_local
;
1960 case Lisp_Misc_Some_Buffer_Local_Value
:
1961 strout ("#<some_buffer_local_value ", -1, -1, printcharfun
, 0);
1963 strout ("[realvalue] ", -1, -1, printcharfun
, 0);
1964 print_object (XBUFFER_LOCAL_VALUE (obj
)->realvalue
,
1965 printcharfun
, escapeflag
);
1966 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_buffer
)
1967 strout ("[local in buffer] ", -1, -1, printcharfun
, 0);
1969 strout ("[buffer] ", -1, -1, printcharfun
, 0);
1970 print_object (XBUFFER_LOCAL_VALUE (obj
)->buffer
,
1971 printcharfun
, escapeflag
);
1972 if (XBUFFER_LOCAL_VALUE (obj
)->check_frame
)
1974 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_frame
)
1975 strout ("[local in frame] ", -1, -1, printcharfun
, 0);
1977 strout ("[frame] ", -1, -1, printcharfun
, 0);
1978 print_object (XBUFFER_LOCAL_VALUE (obj
)->frame
,
1979 printcharfun
, escapeflag
);
1981 strout ("[alist-elt] ", -1, -1, printcharfun
, 0);
1982 print_object (XCAR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
1983 printcharfun
, escapeflag
);
1984 strout ("[default-value] ", -1, -1, printcharfun
, 0);
1985 print_object (XCDR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
1986 printcharfun
, escapeflag
);
1998 /* We're in trouble if this happens!
1999 Probably should just abort () */
2000 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
, 0);
2002 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2003 else if (VECTORLIKEP (obj
))
2004 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
2006 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2007 strout (buf
, -1, -1, printcharfun
, 0);
2008 strout (" Save your buffers immediately and please report this bug>",
2009 -1, -1, printcharfun
, 0);
2017 /* Print a description of INTERVAL using PRINTCHARFUN.
2018 This is part of printing a string that has text properties. */
2021 print_interval (interval
, printcharfun
)
2023 Lisp_Object printcharfun
;
2026 print_object (make_number (interval
->position
), printcharfun
, 1);
2028 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2031 print_object (interval
->plist
, printcharfun
, 1);
2038 Qtemp_buffer_setup_hook
= intern ("temp-buffer-setup-hook");
2039 staticpro (&Qtemp_buffer_setup_hook
);
2041 DEFVAR_LISP ("standard-output", &Vstandard_output
,
2042 doc
: /* Output stream `print' uses by default for outputting a character.
2043 This may be any function of one argument.
2044 It may also be a buffer (output is inserted before point)
2045 or a marker (output is inserted and the marker is advanced)
2046 or the symbol t (output appears in the echo area). */);
2047 Vstandard_output
= Qt
;
2048 Qstandard_output
= intern ("standard-output");
2049 staticpro (&Qstandard_output
);
2051 DEFVAR_LISP ("float-output-format", &Vfloat_output_format
,
2052 doc
: /* The format descriptor string used to print floats.
2053 This is a %-spec like those accepted by `printf' in C,
2054 but with some restrictions. It must start with the two characters `%.'.
2055 After that comes an integer precision specification,
2056 and then a letter which controls the format.
2057 The letters allowed are `e', `f' and `g'.
2058 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2059 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2060 Use `g' to choose the shorter of those two formats for the number at hand.
2061 The precision in any of these cases is the number of digits following
2062 the decimal point. With `f', a precision of 0 means to omit the
2063 decimal point. 0 is not allowed with `e' or `g'.
2065 A value of nil means to use the shortest notation
2066 that represents the number without losing information. */);
2067 Vfloat_output_format
= Qnil
;
2068 Qfloat_output_format
= intern ("float-output-format");
2069 staticpro (&Qfloat_output_format
);
2071 DEFVAR_LISP ("print-length", &Vprint_length
,
2072 doc
: /* Maximum length of list to print before abbreviating.
2073 A value of nil means no limit. See also `eval-expression-print-length'. */);
2074 Vprint_length
= Qnil
;
2076 DEFVAR_LISP ("print-level", &Vprint_level
,
2077 doc
: /* Maximum depth of list nesting to print before abbreviating.
2078 A value of nil means no limit. See also `eval-expression-print-level'. */);
2079 Vprint_level
= Qnil
;
2081 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines
,
2082 doc
: /* Non-nil means print newlines in strings as `\\n'.
2083 Also print formfeeds as `\\f'. */);
2084 print_escape_newlines
= 0;
2086 DEFVAR_BOOL ("print-escape-nonascii", &print_escape_nonascii
,
2087 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2088 \(OOO is the octal representation of the character code.)
2089 Only single-byte characters are affected, and only in `prin1'.
2090 When the output goes in a multibyte buffer, this feature is
2091 enabled regardless of the value of the variable. */);
2092 print_escape_nonascii
= 0;
2094 DEFVAR_BOOL ("print-escape-multibyte", &print_escape_multibyte
,
2095 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2096 \(XXXX is the hex representation of the character code.)
2097 This affects only `prin1'. */);
2098 print_escape_multibyte
= 0;
2100 DEFVAR_BOOL ("print-quoted", &print_quoted
,
2101 doc
: /* Non-nil means print quoted forms with reader syntax.
2102 I.e., (quote foo) prints as 'foo, (function foo) as #'foo, and backquoted
2103 forms print as in the new syntax. */);
2106 DEFVAR_LISP ("print-gensym", &Vprint_gensym
,
2107 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2108 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2109 When the uninterned symbol appears within a recursive data structure,
2110 and the symbol appears more than once, in addition use the #N# and #N=
2111 constructs as needed, so that multiple references to the same symbol are
2112 shared once again when the text is read back. */);
2113 Vprint_gensym
= Qnil
;
2115 DEFVAR_LISP ("print-circle", &Vprint_circle
,
2116 doc
: /* *Non-nil means print recursive structures using #N= and #N# syntax.
2117 If nil, printing proceeds recursively and may lead to
2118 `max-lisp-eval-depth' being exceeded or an error may occur:
2119 \"Apparently circular structure being printed.\" Also see
2120 `print-length' and `print-level'.
2121 If non-nil, shared substructures anywhere in the structure are printed
2122 with `#N=' before the first occurrence (in the order of the print
2123 representation) and `#N#' in place of each subsequent occurrence,
2124 where N is a positive decimal integer. */);
2125 Vprint_circle
= Qnil
;
2127 DEFVAR_LISP ("print-continuous-numbering", &Vprint_continuous_numbering
,
2128 doc
: /* *Non-nil means number continuously across print calls.
2129 This affects the numbers printed for #N= labels and #M# references.
2130 See also `print-circle', `print-gensym', and `print-number-table'.
2131 This variable should not be set with `setq'; bind it with a `let' instead. */);
2132 Vprint_continuous_numbering
= Qnil
;
2134 DEFVAR_LISP ("print-number-table", &Vprint_number_table
,
2135 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2136 The Lisp printer uses this vector to detect Lisp objects referenced more
2139 When you bind `print-continuous-numbering' to t, you should probably
2140 also bind `print-number-table' to nil. This ensures that the value of
2141 `print-number-table' can be garbage-collected once the printing is
2142 done. If all elements of `print-number-table' are nil, it means that
2143 the printing done so far has not found any shared structure or objects
2144 that need to be recorded in the table. */);
2145 Vprint_number_table
= Qnil
;
2147 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2148 staticpro (&Vprin1_to_string_buffer
);
2151 defsubr (&Sprin1_to_string
);
2152 defsubr (&Serror_message_string
);
2156 defsubr (&Swrite_char
);
2157 defsubr (&Sexternal_debugging_output
);
2159 Qexternal_debugging_output
= intern ("external-debugging-output");
2160 staticpro (&Qexternal_debugging_output
);
2162 Qprint_escape_newlines
= intern ("print-escape-newlines");
2163 staticpro (&Qprint_escape_newlines
);
2165 Qprint_escape_multibyte
= intern ("print-escape-multibyte");
2166 staticpro (&Qprint_escape_multibyte
);
2168 Qprint_escape_nonascii
= intern ("print-escape-nonascii");
2169 staticpro (&Qprint_escape_nonascii
);
2171 defsubr (&Swith_output_to_temp_buffer
);