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. */
27 #include "character.h"
33 #include "dispextern.h"
35 #include "intervals.h"
37 Lisp_Object Vstandard_output
, Qstandard_output
;
39 Lisp_Object Qtemp_buffer_setup_hook
;
41 /* These are used to print like we read. */
42 extern Lisp_Object Qbackquote
, Qcomma
, Qcomma_at
, Qcomma_dot
, Qfunction
;
44 Lisp_Object Vfloat_output_format
, Qfloat_output_format
;
46 /* Work around a problem that happens because math.h on hpux 7
47 defines two static variables--which, in Emacs, are not really static,
48 because `static' is defined as nothing. The problem is that they are
49 defined both here and in lread.c.
50 These macros prevent the name conflict. */
51 #if defined (HPUX) && !defined (HPUX8)
52 #define _MAXLDBL print_maxldbl
53 #define _NMAXLDBL print_nmaxldbl
62 /* Default to values appropriate for IEEE floating point. */
67 #define DBL_MANT_DIG 53
73 #define DBL_MIN 2.2250738585072014e-308
76 #ifdef DBL_MIN_REPLACEMENT
78 #define DBL_MIN DBL_MIN_REPLACEMENT
81 /* Define DOUBLE_DIGITS_BOUND, an upper bound on the number of decimal digits
82 needed to express a float without losing information.
83 The general-case formula is valid for the usual case, IEEE floating point,
84 but many compilers can't optimize the formula to an integer constant,
85 so make a special case for it. */
86 #if FLT_RADIX == 2 && DBL_MANT_DIG == 53
87 #define DOUBLE_DIGITS_BOUND 17 /* IEEE floating point */
89 #define DOUBLE_DIGITS_BOUND ((int) ceil (log10 (pow (FLT_RADIX, DBL_MANT_DIG))))
92 /* Avoid actual stack overflow in print. */
95 /* Nonzero if inside outputting backquote in old style. */
96 int old_backquote_output
;
98 /* Detect most circularities to print finite output. */
99 #define PRINT_CIRCLE 200
100 Lisp_Object being_printed
[PRINT_CIRCLE
];
102 /* When printing into a buffer, first we put the text in this
103 block, then insert it all at once. */
106 /* Size allocated in print_buffer. */
107 int print_buffer_size
;
108 /* Chars stored in print_buffer. */
109 int print_buffer_pos
;
110 /* Bytes stored in print_buffer. */
111 int print_buffer_pos_byte
;
113 /* Maximum length of list to print in full; noninteger means
114 effectively infinity */
116 Lisp_Object Vprint_length
;
118 /* Maximum depth of list to print in full; noninteger means
119 effectively infinity. */
121 Lisp_Object Vprint_level
;
123 /* Nonzero means print newlines in strings as \n. */
125 int print_escape_newlines
;
127 /* Nonzero means to print single-byte non-ascii characters in strings as
130 int print_escape_nonascii
;
132 /* Nonzero means to print multibyte characters in strings as hex escapes. */
134 int print_escape_multibyte
;
136 Lisp_Object Qprint_escape_newlines
;
137 Lisp_Object Qprint_escape_multibyte
, Qprint_escape_nonascii
;
139 /* Nonzero means print (quote foo) forms as 'foo, etc. */
143 /* Non-nil means print #: before uninterned symbols. */
145 Lisp_Object Vprint_gensym
;
147 /* Non-nil means print recursive structures using #n= and #n# syntax. */
149 Lisp_Object Vprint_circle
;
151 /* Non-nil means keep continuous number for #n= and #n# syntax
152 between several print functions. */
154 Lisp_Object Vprint_continuous_numbering
;
156 /* Vprint_number_table is a vector like [OBJ1 STAT1 OBJ2 STAT2 ...],
157 where OBJn are objects going to be printed, and STATn are their status,
158 which may be different meanings during process. See the comments of
159 the functions print and print_preprocess for details.
160 print_number_index keeps the last position the next object should be added,
161 twice of which is the actual vector position in Vprint_number_table. */
162 int print_number_index
;
163 Lisp_Object Vprint_number_table
;
165 /* PRINT_NUMBER_OBJECT returns the I'th object in Vprint_number_table TABLE.
166 PRINT_NUMBER_STATUS returns the status of the I'th object in TABLE.
167 See the comment of the variable Vprint_number_table. */
168 #define PRINT_NUMBER_OBJECT(table,i) XVECTOR ((table))->contents[(i) * 2]
169 #define PRINT_NUMBER_STATUS(table,i) XVECTOR ((table))->contents[(i) * 2 + 1]
171 /* Nonzero means print newline to stdout before next minibuffer message.
172 Defined in xdisp.c */
174 extern int noninteractive_need_newline
;
176 extern int minibuffer_auto_raise
;
178 #ifdef MAX_PRINT_CHARS
179 static int print_chars
;
180 static int max_print
;
181 #endif /* MAX_PRINT_CHARS */
183 void print_interval ();
186 /* Low level output routines for characters and strings */
188 /* Lisp functions to do output using a stream
189 must have the stream in a variable called printcharfun
190 and must start with PRINTPREPARE, end with PRINTFINISH,
191 and use PRINTDECLARE to declare common variables.
192 Use PRINTCHAR to output one character,
193 or call strout to output a block of characters. */
195 #define PRINTDECLARE \
196 struct buffer *old = current_buffer; \
197 int old_point = -1, start_point = -1; \
198 int old_point_byte = -1, start_point_byte = -1; \
199 int specpdl_count = SPECPDL_INDEX (); \
200 int free_print_buffer = 0; \
201 int multibyte = !NILP (current_buffer->enable_multibyte_characters); \
204 #define PRINTPREPARE \
205 original = printcharfun; \
206 if (NILP (printcharfun)) printcharfun = Qt; \
207 if (BUFFERP (printcharfun)) \
209 if (XBUFFER (printcharfun) != current_buffer) \
210 Fset_buffer (printcharfun); \
211 printcharfun = Qnil; \
213 if (MARKERP (printcharfun)) \
215 if (!(XMARKER (original)->buffer)) \
216 error ("Marker does not point anywhere"); \
217 if (XMARKER (original)->buffer != current_buffer) \
218 set_buffer_internal (XMARKER (original)->buffer); \
220 old_point_byte = PT_BYTE; \
221 SET_PT_BOTH (marker_position (printcharfun), \
222 marker_byte_position (printcharfun)); \
224 start_point_byte = PT_BYTE; \
225 printcharfun = Qnil; \
227 if (NILP (printcharfun)) \
229 Lisp_Object string; \
230 if (NILP (current_buffer->enable_multibyte_characters) \
231 && ! print_escape_multibyte) \
232 specbind (Qprint_escape_multibyte, Qt); \
233 if (! NILP (current_buffer->enable_multibyte_characters) \
234 && ! print_escape_nonascii) \
235 specbind (Qprint_escape_nonascii, Qt); \
236 if (print_buffer != 0) \
238 string = make_string_from_bytes (print_buffer, \
240 print_buffer_pos_byte); \
241 record_unwind_protect (print_unwind, string); \
245 print_buffer_size = 1000; \
246 print_buffer = (char *) xmalloc (print_buffer_size); \
247 free_print_buffer = 1; \
249 print_buffer_pos = 0; \
250 print_buffer_pos_byte = 0; \
252 if (EQ (printcharfun, Qt) && ! noninteractive) \
253 setup_echo_area_for_printing (multibyte);
255 #define PRINTFINISH \
256 if (NILP (printcharfun)) \
258 if (print_buffer_pos != print_buffer_pos_byte \
259 && NILP (current_buffer->enable_multibyte_characters)) \
261 unsigned char *temp \
262 = (unsigned char *) alloca (print_buffer_pos + 1); \
263 copy_text (print_buffer, temp, print_buffer_pos_byte, \
265 insert_1_both (temp, print_buffer_pos, \
266 print_buffer_pos, 0, 1, 0); \
269 insert_1_both (print_buffer, print_buffer_pos, \
270 print_buffer_pos_byte, 0, 1, 0); \
272 if (free_print_buffer) \
274 xfree (print_buffer); \
277 unbind_to (specpdl_count, Qnil); \
278 if (MARKERP (original)) \
279 set_marker_both (original, Qnil, PT, PT_BYTE); \
280 if (old_point >= 0) \
281 SET_PT_BOTH (old_point + (old_point >= start_point \
282 ? PT - start_point : 0), \
283 old_point_byte + (old_point_byte >= start_point_byte \
284 ? PT_BYTE - start_point_byte : 0)); \
285 if (old != current_buffer) \
286 set_buffer_internal (old);
288 #define PRINTCHAR(ch) printchar (ch, printcharfun)
290 /* This is used to restore the saved contents of print_buffer
291 when there is a recursive call to print. */
294 print_unwind (saved_text
)
295 Lisp_Object saved_text
;
297 bcopy (SDATA (saved_text
), print_buffer
, SCHARS (saved_text
));
302 /* Print character CH using method FUN. FUN nil means print to
303 print_buffer. FUN t means print to echo area or stdout if
304 non-interactive. If FUN is neither nil nor t, call FUN with CH as
312 #ifdef MAX_PRINT_CHARS
315 #endif /* MAX_PRINT_CHARS */
317 if (!NILP (fun
) && !EQ (fun
, Qt
))
318 call1 (fun
, make_number (ch
));
321 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
322 int len
= CHAR_STRING (ch
, str
);
328 if (print_buffer_pos_byte
+ len
>= print_buffer_size
)
329 print_buffer
= (char *) xrealloc (print_buffer
,
330 print_buffer_size
*= 2);
331 bcopy (str
, print_buffer
+ print_buffer_pos_byte
, len
);
332 print_buffer_pos
+= 1;
333 print_buffer_pos_byte
+= len
;
335 else if (noninteractive
)
337 fwrite (str
, 1, len
, stdout
);
338 noninteractive_need_newline
= 1;
343 = !NILP (current_buffer
->enable_multibyte_characters
);
345 setup_echo_area_for_printing (multibyte_p
);
347 message_dolog (str
, len
, 0, multibyte_p
);
353 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
354 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
355 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
356 print_buffer. PRINTCHARFUN t means output to the echo area or to
357 stdout if non-interactive. If neither nil nor t, call Lisp
358 function PRINTCHARFUN for each character printed. MULTIBYTE
359 non-zero means PTR contains multibyte characters. */
362 strout (ptr
, size
, size_byte
, printcharfun
, multibyte
)
365 Lisp_Object printcharfun
;
369 size_byte
= size
= strlen (ptr
);
371 if (NILP (printcharfun
))
373 if (print_buffer_pos_byte
+ size_byte
> print_buffer_size
)
375 print_buffer_size
= print_buffer_size
* 2 + size_byte
;
376 print_buffer
= (char *) xrealloc (print_buffer
,
379 bcopy (ptr
, print_buffer
+ print_buffer_pos_byte
, size_byte
);
380 print_buffer_pos
+= size
;
381 print_buffer_pos_byte
+= size_byte
;
383 #ifdef MAX_PRINT_CHARS
386 #endif /* MAX_PRINT_CHARS */
388 else if (noninteractive
&& EQ (printcharfun
, Qt
))
390 fwrite (ptr
, 1, size_byte
, stdout
);
391 noninteractive_need_newline
= 1;
393 else if (EQ (printcharfun
, Qt
))
395 /* Output to echo area. We're trying to avoid a little overhead
396 here, that's the reason we don't call printchar to do the
400 = !NILP (current_buffer
->enable_multibyte_characters
);
402 setup_echo_area_for_printing (multibyte_p
);
403 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
405 if (size
== size_byte
)
407 for (i
= 0; i
< size
; ++i
)
408 insert_char ((unsigned char )*ptr
++);
413 for (i
= 0; i
< size_byte
; i
+= len
)
415 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size_byte
- i
, len
);
420 #ifdef MAX_PRINT_CHARS
423 #endif /* MAX_PRINT_CHARS */
427 /* PRINTCHARFUN is a Lisp function. */
430 if (size
== size_byte
)
432 while (i
< size_byte
)
440 while (i
< size_byte
)
442 /* Here, we must convert each multi-byte form to the
443 corresponding character code before handing it to
446 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size_byte
- i
, len
);
454 /* Print the contents of a string STRING using PRINTCHARFUN.
455 It isn't safe to use strout in many cases,
456 because printing one char can relocate. */
459 print_string (string
, printcharfun
)
461 Lisp_Object printcharfun
;
463 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
467 if (print_escape_nonascii
)
468 string
= string_escape_byte8 (string
);
470 if (STRING_MULTIBYTE (string
))
471 chars
= SCHARS (string
);
472 else if (! print_escape_nonascii
473 && (EQ (printcharfun
, Qt
)
474 ? ! NILP (buffer_defaults
.enable_multibyte_characters
)
475 : ! NILP (current_buffer
->enable_multibyte_characters
)))
477 /* If unibyte string STRING contains 8-bit codes, we must
478 convert STRING to a multibyte string containing the same
483 chars
= SBYTES (string
);
484 bytes
= parse_str_to_multibyte (SDATA (string
), chars
);
487 newstr
= make_uninit_multibyte_string (chars
, bytes
);
488 bcopy (SDATA (string
), SDATA (newstr
), chars
);
489 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
494 chars
= SBYTES (string
);
496 /* strout is safe for output to a frame (echo area) or to print_buffer. */
497 strout (SDATA (string
),
498 chars
, SBYTES (string
),
499 printcharfun
, STRING_MULTIBYTE (string
));
503 /* Otherwise, string may be relocated by printing one char.
504 So re-fetch the string address for each character. */
506 int size
= SCHARS (string
);
507 int size_byte
= SBYTES (string
);
510 if (size
== size_byte
)
511 for (i
= 0; i
< size
; i
++)
512 PRINTCHAR (SREF (string
, i
));
514 for (i
= 0; i
< size_byte
; i
++)
516 /* Here, we must convert each multi-byte form to the
517 corresponding character code before handing it to PRINTCHAR. */
519 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
,
528 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
529 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
530 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
531 (character
, printcharfun
)
532 Lisp_Object character
, printcharfun
;
536 if (NILP (printcharfun
))
537 printcharfun
= Vstandard_output
;
538 CHECK_NUMBER (character
);
540 PRINTCHAR (XINT (character
));
545 /* Used from outside of print.c to print a block of SIZE
546 single-byte chars at DATA on the default output stream.
547 Do not use this on the contents of a Lisp string. */
550 write_string (data
, size
)
555 Lisp_Object printcharfun
;
557 printcharfun
= Vstandard_output
;
560 strout (data
, size
, size
, printcharfun
, 0);
564 /* Used from outside of print.c to print a block of SIZE
565 single-byte chars at DATA on a specified stream PRINTCHARFUN.
566 Do not use this on the contents of a Lisp string. */
569 write_string_1 (data
, size
, printcharfun
)
572 Lisp_Object printcharfun
;
577 strout (data
, size
, size
, printcharfun
, 0);
583 temp_output_buffer_setup (bufname
)
586 int count
= SPECPDL_INDEX ();
587 register struct buffer
*old
= current_buffer
;
588 register Lisp_Object buf
;
590 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
592 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
594 Fkill_all_local_variables ();
595 delete_all_overlays (current_buffer
);
596 current_buffer
->directory
= old
->directory
;
597 current_buffer
->read_only
= Qnil
;
598 current_buffer
->filename
= Qnil
;
599 current_buffer
->undo_list
= Qt
;
600 eassert (current_buffer
->overlays_before
== NULL
);
601 eassert (current_buffer
->overlays_after
== NULL
);
602 current_buffer
->enable_multibyte_characters
603 = buffer_defaults
.enable_multibyte_characters
;
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
);
1310 /* A flag to control printing of `charset' text property.
1311 The default value is Qdefault. */
1312 Lisp_Object Vprint_charset_text_property
;
1313 extern Lisp_Object Qdefault
;
1315 static void print_check_string_charset_prop ();
1317 #define PRINT_STRING_NON_CHARSET_FOUND 1
1318 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1320 /* Bitwize or of the abobe macros. */
1321 static int print_check_string_result
;
1324 print_check_string_charset_prop (interval
, string
)
1330 if (NILP (interval
->plist
)
1331 || (print_check_string_result
== (PRINT_STRING_NON_CHARSET_FOUND
1332 | PRINT_STRING_UNSAFE_CHARSET_FOUND
)))
1334 for (val
= interval
->plist
; CONSP (val
) && ! EQ (XCAR (val
), Qcharset
);
1335 val
= XCDR (XCDR (val
)));
1338 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1341 if (! (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
))
1343 if (! EQ (val
, interval
->plist
)
1344 || CONSP (XCDR (XCDR (val
))))
1345 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1347 if (NILP (Vprint_charset_text_property
)
1348 || ! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1351 int charpos
= interval
->position
;
1352 int bytepos
= string_char_to_byte (string
, charpos
);
1353 Lisp_Object charset
;
1355 charset
= XCAR (XCDR (val
));
1356 for (i
= 0; i
< LENGTH (interval
); i
++)
1358 FETCH_STRING_CHAR_ADVANCE (c
, string
, charpos
, bytepos
);
1359 if (! EQ (CHARSET_NAME (CHAR_CHARSET (c
)), charset
))
1361 print_check_string_result
|= PRINT_STRING_UNSAFE_CHARSET_FOUND
;
1368 /* The value is (charset . nil). */
1369 static Lisp_Object print_prune_charset_plist
;
1372 print_prune_string_charset (string
)
1375 print_check_string_result
= 0;
1376 traverse_intervals (STRING_INTERVALS (string
), 0,
1377 print_check_string_charset_prop
, string
);
1378 if (! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1380 string
= Fcopy_sequence (string
);
1381 if (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
)
1383 if (NILP (print_prune_charset_plist
))
1384 print_prune_charset_plist
= Fcons (Qcharset
, Qnil
);
1385 Fremove_text_properties (0, SCHARS (string
),
1386 print_prune_charset_plist
, string
);
1389 Fset_text_properties (0, SCHARS (string
), Qnil
, string
);
1395 print_object (obj
, printcharfun
, escapeflag
)
1397 register Lisp_Object printcharfun
;
1404 /* Detect circularities and truncate them. */
1405 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1406 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
)
1407 || (! NILP (Vprint_gensym
)
1409 && !SYMBOL_INTERNED_P (obj
)))
1411 if (NILP (Vprint_circle
) && NILP (Vprint_gensym
))
1413 /* Simple but incomplete way. */
1415 for (i
= 0; i
< print_depth
; i
++)
1416 if (EQ (obj
, being_printed
[i
]))
1418 sprintf (buf
, "#%d", i
);
1419 strout (buf
, -1, -1, printcharfun
, 0);
1422 being_printed
[print_depth
] = obj
;
1426 /* With the print-circle feature. */
1428 for (i
= 0; i
< print_number_index
; i
++)
1429 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
), obj
))
1431 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1433 /* Add a prefix #n= if OBJ has not yet been printed;
1434 that is, its status field is nil. */
1435 sprintf (buf
, "#%d=", i
+ 1);
1436 strout (buf
, -1, -1, printcharfun
, 0);
1437 /* OBJ is going to be printed. Set the status to t. */
1438 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1443 /* Just print #n# if OBJ has already been printed. */
1444 sprintf (buf
, "#%d#", i
+ 1);
1445 strout (buf
, -1, -1, printcharfun
, 0);
1454 if (print_depth
> PRINT_CIRCLE
)
1455 error ("Apparently circular structure being printed");
1456 #ifdef MAX_PRINT_CHARS
1457 if (max_print
&& print_chars
> max_print
)
1462 #endif /* MAX_PRINT_CHARS */
1464 switch (XGCTYPE (obj
))
1467 if (sizeof (int) == sizeof (EMACS_INT
))
1468 sprintf (buf
, "%d", XINT (obj
));
1469 else if (sizeof (long) == sizeof (EMACS_INT
))
1470 sprintf (buf
, "%ld", (long) XINT (obj
));
1473 strout (buf
, -1, -1, printcharfun
, 0);
1478 char pigbuf
[350]; /* see comments in float_to_string */
1480 float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1481 strout (pigbuf
, -1, -1, printcharfun
, 0);
1487 print_string (obj
, printcharfun
);
1490 register int i
, i_byte
;
1491 struct gcpro gcpro1
;
1494 /* 1 means we must ensure that the next character we output
1495 cannot be taken as part of a hex character escape. */
1496 int need_nonhex
= 0;
1497 int multibyte
= STRING_MULTIBYTE (obj
);
1501 if (! EQ (Vprint_charset_text_property
, Qt
))
1502 obj
= print_prune_string_charset (obj
);
1504 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1512 size_byte
= SBYTES (obj
);
1514 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1516 /* Here, we must convert each multi-byte form to the
1517 corresponding character code before handing it to PRINTCHAR. */
1523 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
,
1524 size_byte
- i_byte
, len
);
1532 if (c
== '\n' && print_escape_newlines
)
1537 else if (c
== '\f' && print_escape_newlines
)
1543 && (CHAR_BYTE8_P (c
)
1544 || (! ASCII_CHAR_P (c
) && print_escape_multibyte
)))
1546 /* When multibyte is disabled,
1547 print multibyte string chars using hex escapes.
1548 For a char code that could be in a unibyte string,
1549 when found in a multibyte string, always use a hex escape
1550 so it reads back as multibyte. */
1551 unsigned char outbuf
[50];
1553 if (CHAR_BYTE8_P (c
))
1554 sprintf (outbuf
, "\\%03o", CHAR_TO_BYTE8 (c
));
1557 sprintf (outbuf
, "\\x%04x", c
);
1560 strout (outbuf
, -1, -1, printcharfun
, 0);
1562 else if (! multibyte
1563 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1564 && print_escape_nonascii
)
1566 /* When printing in a multibyte buffer
1567 or when explicitly requested,
1568 print single-byte non-ASCII string chars
1569 using octal escapes. */
1570 unsigned char outbuf
[5];
1571 sprintf (outbuf
, "\\%03o", c
);
1572 strout (outbuf
, -1, -1, printcharfun
, 0);
1576 /* If we just had a hex escape, and this character
1577 could be taken as part of it,
1578 output `\ ' to prevent that. */
1582 if ((c
>= 'a' && c
<= 'f')
1583 || (c
>= 'A' && c
<= 'F')
1584 || (c
>= '0' && c
<= '9'))
1585 strout ("\\ ", -1, -1, printcharfun
, 0);
1588 if (c
== '\"' || c
== '\\')
1595 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1597 traverse_intervals (STRING_INTERVALS (obj
),
1598 0, print_interval
, printcharfun
);
1608 register int confusing
;
1609 register unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1610 register unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1612 int i
, i_byte
, size_byte
;
1615 name
= SYMBOL_NAME (obj
);
1617 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1620 /* If symbol name begins with a digit, and ends with a digit,
1621 and contains nothing but digits and `e', it could be treated
1622 as a number. So set CONFUSING.
1624 Symbols that contain periods could also be taken as numbers,
1625 but periods are always escaped, so we don't have to worry
1627 else if (*p
>= '0' && *p
<= '9'
1628 && end
[-1] >= '0' && end
[-1] <= '9')
1630 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1631 /* Needed for \2e10. */
1634 confusing
= (end
== p
);
1639 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1645 size_byte
= SBYTES (name
);
1647 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1649 /* Here, we must convert each multi-byte form to the
1650 corresponding character code before handing it to PRINTCHAR. */
1651 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1656 if (c
== '\"' || c
== '\\' || c
== '\''
1657 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1658 || c
== ',' || c
=='.' || c
== '`'
1659 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1661 PRINTCHAR ('\\'), confusing
= 0;
1669 /* If deeper than spec'd depth, print placeholder. */
1670 if (INTEGERP (Vprint_level
)
1671 && print_depth
> XINT (Vprint_level
))
1672 strout ("...", -1, -1, printcharfun
, 0);
1673 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1674 && (EQ (XCAR (obj
), Qquote
)))
1677 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1679 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1680 && (EQ (XCAR (obj
), Qfunction
)))
1684 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1686 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1687 && ! old_backquote_output
1688 && ((EQ (XCAR (obj
), Qbackquote
)
1689 || EQ (XCAR (obj
), Qcomma
)
1690 || EQ (XCAR (obj
), Qcomma_at
)
1691 || EQ (XCAR (obj
), Qcomma_dot
))))
1693 print_object (XCAR (obj
), printcharfun
, 0);
1694 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1700 /* If the first element is a backquote form,
1701 print it old-style so it won't be misunderstood. */
1702 if (print_quoted
&& CONSP (XCAR (obj
))
1703 && CONSP (XCDR (XCAR (obj
)))
1704 && NILP (XCDR (XCDR (XCAR (obj
))))
1705 && EQ (XCAR (XCAR (obj
)), Qbackquote
))
1711 print_object (Qbackquote
, printcharfun
, 0);
1714 ++old_backquote_output
;
1715 print_object (XCAR (XCDR (tem
)), printcharfun
, 0);
1716 --old_backquote_output
;
1723 int print_length
, i
;
1724 Lisp_Object halftail
= obj
;
1726 /* Negative values of print-length are invalid in CL.
1727 Treat them like nil, as CMUCL does. */
1728 if (NATNUMP (Vprint_length
))
1729 print_length
= XFASTINT (Vprint_length
);
1736 /* Detect circular list. */
1737 if (NILP (Vprint_circle
))
1739 /* Simple but imcomplete way. */
1740 if (i
!= 0 && EQ (obj
, halftail
))
1742 sprintf (buf
, " . #%d", i
/ 2);
1743 strout (buf
, -1, -1, printcharfun
, 0);
1749 /* With the print-circle feature. */
1753 for (i
= 0; i
< print_number_index
; i
++)
1754 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
),
1757 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1759 strout (" . ", 3, 3, printcharfun
, 0);
1760 print_object (obj
, printcharfun
, escapeflag
);
1764 sprintf (buf
, " . #%d#", i
+ 1);
1765 strout (buf
, -1, -1, printcharfun
, 0);
1775 if (print_length
&& i
> print_length
)
1777 strout ("...", 3, 3, printcharfun
, 0);
1781 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1785 halftail
= XCDR (halftail
);
1789 /* OBJ non-nil here means it's the end of a dotted list. */
1792 strout (" . ", 3, 3, printcharfun
, 0);
1793 print_object (obj
, printcharfun
, escapeflag
);
1801 case Lisp_Vectorlike
:
1806 strout ("#<process ", -1, -1, printcharfun
, 0);
1807 print_string (XPROCESS (obj
)->name
, printcharfun
);
1811 print_string (XPROCESS (obj
)->name
, printcharfun
);
1813 else if (BOOL_VECTOR_P (obj
))
1816 register unsigned char c
;
1817 struct gcpro gcpro1
;
1819 = (XBOOL_VECTOR (obj
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1825 if (sizeof (int) == sizeof (EMACS_INT
))
1826 sprintf (buf
, "%d", XBOOL_VECTOR (obj
)->size
);
1827 else if (sizeof (long) == sizeof (EMACS_INT
))
1828 sprintf (buf
, "%ld", XBOOL_VECTOR (obj
)->size
);
1831 strout (buf
, -1, -1, printcharfun
, 0);
1834 /* Don't print more characters than the specified maximum.
1835 Negative values of print-length are invalid. Treat them
1836 like a print-length of nil. */
1837 if (NATNUMP (Vprint_length
)
1838 && XFASTINT (Vprint_length
) < size_in_chars
)
1839 size_in_chars
= XFASTINT (Vprint_length
);
1841 for (i
= 0; i
< size_in_chars
; i
++)
1844 c
= XBOOL_VECTOR (obj
)->data
[i
];
1845 if (! ASCII_BYTE_P (c
))
1847 sprintf (buf
, "\\%03o", c
);
1848 strout (buf
, -1, -1, printcharfun
, 0);
1850 else if (c
== '\n' && print_escape_newlines
)
1855 else if (c
== '\f' && print_escape_newlines
)
1862 if (c
== '\"' || c
== '\\')
1871 else if (SUBRP (obj
))
1873 strout ("#<subr ", -1, -1, printcharfun
, 0);
1874 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
, 0);
1877 else if (WINDOWP (obj
))
1879 strout ("#<window ", -1, -1, printcharfun
, 0);
1880 sprintf (buf
, "%d", XFASTINT (XWINDOW (obj
)->sequence_number
));
1881 strout (buf
, -1, -1, printcharfun
, 0);
1882 if (!NILP (XWINDOW (obj
)->buffer
))
1884 strout (" on ", -1, -1, printcharfun
, 0);
1885 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1889 else if (HASH_TABLE_P (obj
))
1891 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1892 strout ("#<hash-table", -1, -1, printcharfun
, 0);
1893 if (SYMBOLP (h
->test
))
1897 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
, 0);
1899 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
, 0);
1901 sprintf (buf
, "%d/%d", XFASTINT (h
->count
),
1902 XVECTOR (h
->next
)->size
);
1903 strout (buf
, -1, -1, printcharfun
, 0);
1905 sprintf (buf
, " 0x%lx", (unsigned long) h
);
1906 strout (buf
, -1, -1, printcharfun
, 0);
1909 else if (BUFFERP (obj
))
1911 if (NILP (XBUFFER (obj
)->name
))
1912 strout ("#<killed buffer>", -1, -1, printcharfun
, 0);
1913 else if (escapeflag
)
1915 strout ("#<buffer ", -1, -1, printcharfun
, 0);
1916 print_string (XBUFFER (obj
)->name
, printcharfun
);
1920 print_string (XBUFFER (obj
)->name
, printcharfun
);
1922 else if (WINDOW_CONFIGURATIONP (obj
))
1924 strout ("#<window-configuration>", -1, -1, printcharfun
, 0);
1926 else if (FRAMEP (obj
))
1928 strout ((FRAME_LIVE_P (XFRAME (obj
))
1929 ? "#<frame " : "#<dead frame "),
1930 -1, -1, printcharfun
, 0);
1931 print_string (XFRAME (obj
)->name
, printcharfun
);
1932 sprintf (buf
, " 0x%lx", (unsigned long) (XFRAME (obj
)));
1933 strout (buf
, -1, -1, printcharfun
, 0);
1938 int size
= XVECTOR (obj
)->size
;
1939 if (COMPILEDP (obj
))
1942 size
&= PSEUDOVECTOR_SIZE_MASK
;
1944 if (CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
))
1946 /* We print a char-table as if it were a vector,
1947 lumping the parent and default slots in with the
1948 character slots. But we add #^ as a prefix. */
1951 if (SUB_CHAR_TABLE_P (obj
))
1953 size
&= PSEUDOVECTOR_SIZE_MASK
;
1955 if (size
& PSEUDOVECTOR_FLAG
)
1961 register Lisp_Object tem
;
1962 int real_size
= size
;
1964 /* Don't print more elements than the specified maximum. */
1965 if (NATNUMP (Vprint_length
)
1966 && XFASTINT (Vprint_length
) < size
)
1967 size
= XFASTINT (Vprint_length
);
1969 for (i
= 0; i
< size
; i
++)
1971 if (i
) PRINTCHAR (' ');
1972 tem
= XVECTOR (obj
)->contents
[i
];
1973 print_object (tem
, printcharfun
, escapeflag
);
1975 if (size
< real_size
)
1976 strout (" ...", 4, 4, printcharfun
, 0);
1983 switch (XMISCTYPE (obj
))
1985 case Lisp_Misc_Marker
:
1986 strout ("#<marker ", -1, -1, printcharfun
, 0);
1987 /* Do you think this is necessary? */
1988 if (XMARKER (obj
)->insertion_type
!= 0)
1989 strout ("(moves after insertion) ", -1, -1, printcharfun
, 0);
1990 if (!(XMARKER (obj
)->buffer
))
1991 strout ("in no buffer", -1, -1, printcharfun
, 0);
1994 sprintf (buf
, "at %d", marker_position (obj
));
1995 strout (buf
, -1, -1, printcharfun
, 0);
1996 strout (" in ", -1, -1, printcharfun
, 0);
1997 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
2002 case Lisp_Misc_Overlay
:
2003 strout ("#<overlay ", -1, -1, printcharfun
, 0);
2004 if (!(XMARKER (OVERLAY_START (obj
))->buffer
))
2005 strout ("in no buffer", -1, -1, printcharfun
, 0);
2008 sprintf (buf
, "from %d to %d in ",
2009 marker_position (OVERLAY_START (obj
)),
2010 marker_position (OVERLAY_END (obj
)));
2011 strout (buf
, -1, -1, printcharfun
, 0);
2012 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
2018 /* Remaining cases shouldn't happen in normal usage, but let's print
2019 them anyway for the benefit of the debugger. */
2020 case Lisp_Misc_Free
:
2021 strout ("#<misc free cell>", -1, -1, printcharfun
, 0);
2024 case Lisp_Misc_Intfwd
:
2025 sprintf (buf
, "#<intfwd to %d>", *XINTFWD (obj
)->intvar
);
2026 strout (buf
, -1, -1, printcharfun
, 0);
2029 case Lisp_Misc_Boolfwd
:
2030 sprintf (buf
, "#<boolfwd to %s>",
2031 (*XBOOLFWD (obj
)->boolvar
? "t" : "nil"));
2032 strout (buf
, -1, -1, printcharfun
, 0);
2035 case Lisp_Misc_Objfwd
:
2036 strout ("#<objfwd to ", -1, -1, printcharfun
, 0);
2037 print_object (*XOBJFWD (obj
)->objvar
, printcharfun
, escapeflag
);
2041 case Lisp_Misc_Buffer_Objfwd
:
2042 strout ("#<buffer_objfwd to ", -1, -1, printcharfun
, 0);
2043 print_object (PER_BUFFER_VALUE (current_buffer
,
2044 XBUFFER_OBJFWD (obj
)->offset
),
2045 printcharfun
, escapeflag
);
2049 case Lisp_Misc_Kboard_Objfwd
:
2050 strout ("#<kboard_objfwd to ", -1, -1, printcharfun
, 0);
2051 print_object (*(Lisp_Object
*)((char *) current_kboard
2052 + XKBOARD_OBJFWD (obj
)->offset
),
2053 printcharfun
, escapeflag
);
2057 case Lisp_Misc_Buffer_Local_Value
:
2058 strout ("#<buffer_local_value ", -1, -1, printcharfun
, 0);
2059 goto do_buffer_local
;
2060 case Lisp_Misc_Some_Buffer_Local_Value
:
2061 strout ("#<some_buffer_local_value ", -1, -1, printcharfun
, 0);
2063 strout ("[realvalue] ", -1, -1, printcharfun
, 0);
2064 print_object (XBUFFER_LOCAL_VALUE (obj
)->realvalue
,
2065 printcharfun
, escapeflag
);
2066 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_buffer
)
2067 strout ("[local in buffer] ", -1, -1, printcharfun
, 0);
2069 strout ("[buffer] ", -1, -1, printcharfun
, 0);
2070 print_object (XBUFFER_LOCAL_VALUE (obj
)->buffer
,
2071 printcharfun
, escapeflag
);
2072 if (XBUFFER_LOCAL_VALUE (obj
)->check_frame
)
2074 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_frame
)
2075 strout ("[local in frame] ", -1, -1, printcharfun
, 0);
2077 strout ("[frame] ", -1, -1, printcharfun
, 0);
2078 print_object (XBUFFER_LOCAL_VALUE (obj
)->frame
,
2079 printcharfun
, escapeflag
);
2081 strout ("[alist-elt] ", -1, -1, printcharfun
, 0);
2082 print_object (XCAR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
2083 printcharfun
, escapeflag
);
2084 strout ("[default-value] ", -1, -1, printcharfun
, 0);
2085 print_object (XCDR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
2086 printcharfun
, escapeflag
);
2098 /* We're in trouble if this happens!
2099 Probably should just abort () */
2100 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
, 0);
2102 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2103 else if (VECTORLIKEP (obj
))
2104 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
2106 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2107 strout (buf
, -1, -1, printcharfun
, 0);
2108 strout (" Save your buffers immediately and please report this bug>",
2109 -1, -1, printcharfun
, 0);
2117 /* Print a description of INTERVAL using PRINTCHARFUN.
2118 This is part of printing a string that has text properties. */
2121 print_interval (interval
, printcharfun
)
2123 Lisp_Object printcharfun
;
2125 if (NILP (interval
->plist
))
2128 print_object (make_number (interval
->position
), printcharfun
, 1);
2130 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2133 print_object (interval
->plist
, printcharfun
, 1);
2140 Qtemp_buffer_setup_hook
= intern ("temp-buffer-setup-hook");
2141 staticpro (&Qtemp_buffer_setup_hook
);
2143 DEFVAR_LISP ("standard-output", &Vstandard_output
,
2144 doc
: /* Output stream `print' uses by default for outputting a character.
2145 This may be any function of one argument.
2146 It may also be a buffer (output is inserted before point)
2147 or a marker (output is inserted and the marker is advanced)
2148 or the symbol t (output appears in the echo area). */);
2149 Vstandard_output
= Qt
;
2150 Qstandard_output
= intern ("standard-output");
2151 staticpro (&Qstandard_output
);
2153 DEFVAR_LISP ("float-output-format", &Vfloat_output_format
,
2154 doc
: /* The format descriptor string used to print floats.
2155 This is a %-spec like those accepted by `printf' in C,
2156 but with some restrictions. It must start with the two characters `%.'.
2157 After that comes an integer precision specification,
2158 and then a letter which controls the format.
2159 The letters allowed are `e', `f' and `g'.
2160 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2161 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2162 Use `g' to choose the shorter of those two formats for the number at hand.
2163 The precision in any of these cases is the number of digits following
2164 the decimal point. With `f', a precision of 0 means to omit the
2165 decimal point. 0 is not allowed with `e' or `g'.
2167 A value of nil means to use the shortest notation
2168 that represents the number without losing information. */);
2169 Vfloat_output_format
= Qnil
;
2170 Qfloat_output_format
= intern ("float-output-format");
2171 staticpro (&Qfloat_output_format
);
2173 DEFVAR_LISP ("print-length", &Vprint_length
,
2174 doc
: /* Maximum length of list to print before abbreviating.
2175 A value of nil means no limit. See also `eval-expression-print-length'. */);
2176 Vprint_length
= Qnil
;
2178 DEFVAR_LISP ("print-level", &Vprint_level
,
2179 doc
: /* Maximum depth of list nesting to print before abbreviating.
2180 A value of nil means no limit. See also `eval-expression-print-level'. */);
2181 Vprint_level
= Qnil
;
2183 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines
,
2184 doc
: /* Non-nil means print newlines in strings as `\\n'.
2185 Also print formfeeds as `\\f'. */);
2186 print_escape_newlines
= 0;
2188 DEFVAR_BOOL ("print-escape-nonascii", &print_escape_nonascii
,
2189 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2190 \(OOO is the octal representation of the character code.)
2191 Only single-byte characters are affected, and only in `prin1'.
2192 When the output goes in a multibyte buffer, this feature is
2193 enabled regardless of the value of the variable. */);
2194 print_escape_nonascii
= 0;
2196 DEFVAR_BOOL ("print-escape-multibyte", &print_escape_multibyte
,
2197 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2198 \(XXXX is the hex representation of the character code.)
2199 This affects only `prin1'. */);
2200 print_escape_multibyte
= 0;
2202 DEFVAR_BOOL ("print-quoted", &print_quoted
,
2203 doc
: /* Non-nil means print quoted forms with reader syntax.
2204 I.e., (quote foo) prints as 'foo, (function foo) as #'foo, and backquoted
2205 forms print as in the new syntax. */);
2208 DEFVAR_LISP ("print-gensym", &Vprint_gensym
,
2209 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2210 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2211 When the uninterned symbol appears within a recursive data structure,
2212 and the symbol appears more than once, in addition use the #N# and #N=
2213 constructs as needed, so that multiple references to the same symbol are
2214 shared once again when the text is read back. */);
2215 Vprint_gensym
= Qnil
;
2217 DEFVAR_LISP ("print-circle", &Vprint_circle
,
2218 doc
: /* *Non-nil means print recursive structures using #N= and #N# syntax.
2219 If nil, printing proceeds recursively and may lead to
2220 `max-lisp-eval-depth' being exceeded or an error may occur:
2221 \"Apparently circular structure being printed.\" Also see
2222 `print-length' and `print-level'.
2223 If non-nil, shared substructures anywhere in the structure are printed
2224 with `#N=' before the first occurrence (in the order of the print
2225 representation) and `#N#' in place of each subsequent occurrence,
2226 where N is a positive decimal integer. */);
2227 Vprint_circle
= Qnil
;
2229 DEFVAR_LISP ("print-continuous-numbering", &Vprint_continuous_numbering
,
2230 doc
: /* *Non-nil means number continuously across print calls.
2231 This affects the numbers printed for #N= labels and #M# references.
2232 See also `print-circle', `print-gensym', and `print-number-table'.
2233 This variable should not be set with `setq'; bind it with a `let' instead. */);
2234 Vprint_continuous_numbering
= Qnil
;
2236 DEFVAR_LISP ("print-number-table", &Vprint_number_table
,
2237 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2238 The Lisp printer uses this vector to detect Lisp objects referenced more
2241 When you bind `print-continuous-numbering' to t, you should probably
2242 also bind `print-number-table' to nil. This ensures that the value of
2243 `print-number-table' can be garbage-collected once the printing is
2244 done. If all elements of `print-number-table' are nil, it means that
2245 the printing done so far has not found any shared structure or objects
2246 that need to be recorded in the table. */);
2247 Vprint_number_table
= Qnil
;
2249 DEFVAR_LISP ("print-charset-text-property", &Vprint_charset_text_property
,
2250 doc
: /* A flag to control printing of `charset' text property on printing a string.
2251 The value must be nil, t, or `default'.
2253 If the value is nil, don't print the text property `charset'.
2255 If the value is t, always print the text property `charset'.
2257 If the value is `default', print the text property `charset' only when
2258 the value is different from what is guessed in the current charset
2260 Vprint_charset_text_property
= Qdefault
;
2262 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2263 staticpro (&Vprin1_to_string_buffer
);
2266 defsubr (&Sprin1_to_string
);
2267 defsubr (&Serror_message_string
);
2271 defsubr (&Swrite_char
);
2272 defsubr (&Sexternal_debugging_output
);
2274 Qexternal_debugging_output
= intern ("external-debugging-output");
2275 staticpro (&Qexternal_debugging_output
);
2277 Qprint_escape_newlines
= intern ("print-escape-newlines");
2278 staticpro (&Qprint_escape_newlines
);
2280 Qprint_escape_multibyte
= intern ("print-escape-multibyte");
2281 staticpro (&Qprint_escape_multibyte
);
2283 Qprint_escape_nonascii
= intern ("print-escape-nonascii");
2284 staticpro (&Qprint_escape_nonascii
);
2286 print_prune_charset_plist
= Qnil
;
2287 staticpro (&print_prune_charset_plist
);
2289 defsubr (&Swith_output_to_temp_buffer
);