1 /* Lisp object printing and output streams.
2 Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000, 2001
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"
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 /* Detect most circularities to print finite output. */
95 #define PRINT_CIRCLE 200
96 Lisp_Object being_printed
[PRINT_CIRCLE
];
98 /* When printing into a buffer, first we put the text in this
99 block, then insert it all at once. */
102 /* Size allocated in print_buffer. */
103 int print_buffer_size
;
104 /* Chars stored in print_buffer. */
105 int print_buffer_pos
;
106 /* Bytes stored in print_buffer. */
107 int print_buffer_pos_byte
;
109 /* Maximum length of list to print in full; noninteger means
110 effectively infinity */
112 Lisp_Object Vprint_length
;
114 /* Maximum depth of list to print in full; noninteger means
115 effectively infinity. */
117 Lisp_Object Vprint_level
;
119 /* Nonzero means print newlines in strings as \n. */
121 int print_escape_newlines
;
123 /* Nonzero means to print single-byte non-ascii characters in strings as
126 int print_escape_nonascii
;
128 /* Nonzero means to print multibyte characters in strings as hex escapes. */
130 int print_escape_multibyte
;
132 Lisp_Object Qprint_escape_newlines
;
133 Lisp_Object Qprint_escape_multibyte
, Qprint_escape_nonascii
;
135 /* Nonzero means print (quote foo) forms as 'foo, etc. */
139 /* Non-nil means print #: before uninterned symbols. */
141 Lisp_Object Vprint_gensym
;
143 /* Non-nil means print recursive structures using #n= and #n# syntax. */
145 Lisp_Object Vprint_circle
;
147 /* Non-nil means keep continuous number for #n= and #n# syntax
148 between several print functions. */
150 Lisp_Object Vprint_continuous_numbering
;
152 /* Vprint_number_table is a vector like [OBJ1 STAT1 OBJ2 STAT2 ...],
153 where OBJn are objects going to be printed, and STATn are their status,
154 which may be different meanings during process. See the comments of
155 the functions print and print_preprocess for details.
156 print_number_index keeps the last position the next object should be added,
157 twice of which is the actual vector position in Vprint_number_table. */
158 int print_number_index
;
159 Lisp_Object Vprint_number_table
;
161 /* PRINT_NUMBER_OBJECT returns the I'th object in Vprint_number_table TABLE.
162 PRINT_NUMBER_STATUS returns the status of the I'th object in TABLE.
163 See the comment of the variable Vprint_number_table. */
164 #define PRINT_NUMBER_OBJECT(table,i) XVECTOR ((table))->contents[(i) * 2]
165 #define PRINT_NUMBER_STATUS(table,i) XVECTOR ((table))->contents[(i) * 2 + 1]
167 /* Nonzero means print newline to stdout before next minibuffer message.
168 Defined in xdisp.c */
170 extern int noninteractive_need_newline
;
172 extern int minibuffer_auto_raise
;
174 #ifdef MAX_PRINT_CHARS
175 static int print_chars
;
176 static int max_print
;
177 #endif /* MAX_PRINT_CHARS */
179 void print_interval ();
182 /* Low level output routines for characters and strings */
184 /* Lisp functions to do output using a stream
185 must have the stream in a variable called printcharfun
186 and must start with PRINTPREPARE, end with PRINTFINISH,
187 and use PRINTDECLARE to declare common variables.
188 Use PRINTCHAR to output one character,
189 or call strout to output a block of characters. */
191 #define PRINTDECLARE \
192 struct buffer *old = current_buffer; \
193 int old_point = -1, start_point = -1; \
194 int old_point_byte = -1, start_point_byte = -1; \
195 int specpdl_count = specpdl_ptr - specpdl; \
196 int free_print_buffer = 0; \
197 int multibyte = !NILP (current_buffer->enable_multibyte_characters); \
200 #define PRINTPREPARE \
201 original = printcharfun; \
202 if (NILP (printcharfun)) printcharfun = Qt; \
203 if (BUFFERP (printcharfun)) \
205 if (XBUFFER (printcharfun) != current_buffer) \
206 Fset_buffer (printcharfun); \
207 printcharfun = Qnil; \
209 if (MARKERP (printcharfun)) \
211 if (!(XMARKER (original)->buffer)) \
212 error ("Marker does not point anywhere"); \
213 if (XMARKER (original)->buffer != current_buffer) \
214 set_buffer_internal (XMARKER (original)->buffer); \
216 old_point_byte = PT_BYTE; \
217 SET_PT_BOTH (marker_position (printcharfun), \
218 marker_byte_position (printcharfun)); \
220 start_point_byte = PT_BYTE; \
221 printcharfun = Qnil; \
223 if (NILP (printcharfun)) \
225 Lisp_Object string; \
226 if (NILP (current_buffer->enable_multibyte_characters) \
227 && ! print_escape_multibyte) \
228 specbind (Qprint_escape_multibyte, Qt); \
229 if (! NILP (current_buffer->enable_multibyte_characters) \
230 && ! print_escape_nonascii) \
231 specbind (Qprint_escape_nonascii, Qt); \
232 if (print_buffer != 0) \
234 string = make_string_from_bytes (print_buffer, \
236 print_buffer_pos_byte); \
237 record_unwind_protect (print_unwind, string); \
241 print_buffer_size = 1000; \
242 print_buffer = (char *) xmalloc (print_buffer_size); \
243 free_print_buffer = 1; \
245 print_buffer_pos = 0; \
246 print_buffer_pos_byte = 0; \
248 if (EQ (printcharfun, Qt) && ! noninteractive) \
249 setup_echo_area_for_printing (multibyte);
251 #define PRINTFINISH \
252 if (NILP (printcharfun)) \
254 if (print_buffer_pos != print_buffer_pos_byte \
255 && NILP (current_buffer->enable_multibyte_characters)) \
257 unsigned char *temp \
258 = (unsigned char *) alloca (print_buffer_pos + 1); \
259 copy_text (print_buffer, temp, print_buffer_pos_byte, \
261 insert_1_both (temp, print_buffer_pos, \
262 print_buffer_pos, 0, 1, 0); \
265 insert_1_both (print_buffer, print_buffer_pos, \
266 print_buffer_pos_byte, 0, 1, 0); \
268 if (free_print_buffer) \
270 xfree (print_buffer); \
273 unbind_to (specpdl_count, Qnil); \
274 if (MARKERP (original)) \
275 set_marker_both (original, Qnil, PT, PT_BYTE); \
276 if (old_point >= 0) \
277 SET_PT_BOTH (old_point + (old_point >= start_point \
278 ? PT - start_point : 0), \
279 old_point_byte + (old_point_byte >= start_point_byte \
280 ? PT_BYTE - start_point_byte : 0)); \
281 if (old != current_buffer) \
282 set_buffer_internal (old);
284 #define PRINTCHAR(ch) printchar (ch, printcharfun)
286 /* This is used to restore the saved contents of print_buffer
287 when there is a recursive call to print. */
290 print_unwind (saved_text
)
291 Lisp_Object saved_text
;
293 bcopy (XSTRING (saved_text
)->data
, print_buffer
, XSTRING (saved_text
)->size
);
298 /* Print character CH using method FUN. FUN nil means print to
299 print_buffer. FUN t means print to echo area or stdout if
300 non-interactive. If FUN is neither nil nor t, call FUN with CH as
308 #ifdef MAX_PRINT_CHARS
311 #endif /* MAX_PRINT_CHARS */
313 if (!NILP (fun
) && !EQ (fun
, Qt
))
314 call1 (fun
, make_number (ch
));
317 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
318 int len
= CHAR_STRING (ch
, str
);
324 if (print_buffer_pos_byte
+ len
>= print_buffer_size
)
325 print_buffer
= (char *) xrealloc (print_buffer
,
326 print_buffer_size
*= 2);
327 bcopy (str
, print_buffer
+ print_buffer_pos_byte
, len
);
328 print_buffer_pos
+= 1;
329 print_buffer_pos_byte
+= len
;
331 else if (noninteractive
)
333 fwrite (str
, 1, len
, stdout
);
334 noninteractive_need_newline
= 1;
339 = !NILP (current_buffer
->enable_multibyte_characters
);
341 setup_echo_area_for_printing (multibyte_p
);
343 message_dolog (str
, len
, 0, multibyte_p
);
349 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
350 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
351 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
352 print_buffer. PRINTCHARFUN t means output to the echo area or to
353 stdout if non-interactive. If neither nil nor t, call Lisp
354 function PRINTCHARFUN for each character printed. MULTIBYTE
355 non-zero means PTR contains multibyte characters. */
358 strout (ptr
, size
, size_byte
, printcharfun
, multibyte
)
361 Lisp_Object printcharfun
;
365 size_byte
= size
= strlen (ptr
);
367 if (NILP (printcharfun
))
369 if (print_buffer_pos_byte
+ size_byte
> print_buffer_size
)
371 print_buffer_size
= print_buffer_size
* 2 + size_byte
;
372 print_buffer
= (char *) xrealloc (print_buffer
,
375 bcopy (ptr
, print_buffer
+ print_buffer_pos_byte
, size_byte
);
376 print_buffer_pos
+= size
;
377 print_buffer_pos_byte
+= size_byte
;
379 #ifdef MAX_PRINT_CHARS
382 #endif /* MAX_PRINT_CHARS */
384 else if (noninteractive
&& EQ (printcharfun
, Qt
))
386 fwrite (ptr
, 1, size_byte
, stdout
);
387 noninteractive_need_newline
= 1;
389 else if (EQ (printcharfun
, Qt
))
391 /* Output to echo area. We're trying to avoid a little overhead
392 here, that's the reason we don't call printchar to do the
396 = !NILP (current_buffer
->enable_multibyte_characters
);
398 setup_echo_area_for_printing (multibyte_p
);
399 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
401 if (size
== size_byte
)
403 for (i
= 0; i
< size
; ++i
)
404 insert_char ((unsigned char )*ptr
++);
409 for (i
= 0; i
< size_byte
; i
+= len
)
411 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size_byte
- i
, len
);
416 #ifdef MAX_PRINT_CHARS
419 #endif /* MAX_PRINT_CHARS */
423 /* PRINTCHARFUN is a Lisp function. */
426 if (size
== size_byte
)
428 while (i
< size_byte
)
436 while (i
< size_byte
)
438 /* Here, we must convert each multi-byte form to the
439 corresponding character code before handing it to
442 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size_byte
- i
, len
);
450 /* Print the contents of a string STRING using PRINTCHARFUN.
451 It isn't safe to use strout in many cases,
452 because printing one char can relocate. */
455 print_string (string
, printcharfun
)
457 Lisp_Object printcharfun
;
459 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
463 if (print_escape_nonascii
)
464 string
= string_escape_byte8 (string
);
466 if (STRING_MULTIBYTE (string
))
467 chars
= XSTRING (string
)->size
;
468 else if (! print_escape_nonascii
469 && (EQ (printcharfun
, Qt
)
470 ? ! NILP (buffer_defaults
.enable_multibyte_characters
)
471 : ! NILP (current_buffer
->enable_multibyte_characters
)))
473 /* If unibyte string STRING contains 8-bit codes, we must
474 convert STRING to a multibyte string containing the same
479 chars
= STRING_BYTES (XSTRING (string
));
480 bytes
= parse_str_to_multibyte (XSTRING (string
)->data
, chars
);
483 newstr
= make_uninit_multibyte_string (chars
, bytes
);
484 bcopy (XSTRING (string
)->data
, XSTRING (newstr
)->data
, chars
);
485 str_to_multibyte (XSTRING (newstr
)->data
, bytes
, chars
);
490 chars
= STRING_BYTES (XSTRING (string
));
492 /* strout is safe for output to a frame (echo area) or to print_buffer. */
493 strout (XSTRING (string
)->data
,
494 chars
, STRING_BYTES (XSTRING (string
)),
495 printcharfun
, STRING_MULTIBYTE (string
));
499 /* Otherwise, string may be relocated by printing one char.
500 So re-fetch the string address for each character. */
502 int size
= XSTRING (string
)->size
;
503 int size_byte
= STRING_BYTES (XSTRING (string
));
506 if (size
== size_byte
)
507 for (i
= 0; i
< size
; i
++)
508 PRINTCHAR (XSTRING (string
)->data
[i
]);
510 for (i
= 0; i
< size_byte
; i
++)
512 /* Here, we must convert each multi-byte form to the
513 corresponding character code before handing it to PRINTCHAR. */
515 int ch
= STRING_CHAR_AND_LENGTH (XSTRING (string
)->data
+ i
,
524 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
525 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
526 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
527 (character
, printcharfun
)
528 Lisp_Object character
, printcharfun
;
532 if (NILP (printcharfun
))
533 printcharfun
= Vstandard_output
;
534 CHECK_NUMBER (character
);
536 PRINTCHAR (XINT (character
));
541 /* Used from outside of print.c to print a block of SIZE
542 single-byte chars at DATA on the default output stream.
543 Do not use this on the contents of a Lisp string. */
546 write_string (data
, size
)
551 Lisp_Object printcharfun
;
553 printcharfun
= Vstandard_output
;
556 strout (data
, size
, size
, printcharfun
, 0);
560 /* Used from outside of print.c to print a block of SIZE
561 single-byte chars at DATA on a specified stream PRINTCHARFUN.
562 Do not use this on the contents of a Lisp string. */
565 write_string_1 (data
, size
, printcharfun
)
568 Lisp_Object printcharfun
;
573 strout (data
, size
, size
, printcharfun
, 0);
579 temp_output_buffer_setup (bufname
)
582 int count
= specpdl_ptr
- specpdl
;
583 register struct buffer
*old
= current_buffer
;
584 register Lisp_Object buf
;
586 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
588 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
590 current_buffer
->directory
= old
->directory
;
591 current_buffer
->read_only
= Qnil
;
592 current_buffer
->filename
= Qnil
;
593 current_buffer
->undo_list
= Qt
;
594 current_buffer
->overlays_before
= Qnil
;
595 current_buffer
->overlays_after
= Qnil
;
596 current_buffer
->enable_multibyte_characters
597 = buffer_defaults
.enable_multibyte_characters
;
599 XSETBUFFER (buf
, current_buffer
);
601 Frun_hooks (1, &Qtemp_buffer_setup_hook
);
603 unbind_to (count
, Qnil
);
605 specbind (Qstandard_output
, buf
);
609 internal_with_output_to_temp_buffer (bufname
, function
, args
)
611 Lisp_Object (*function
) P_ ((Lisp_Object
));
614 int count
= specpdl_ptr
- specpdl
;
615 Lisp_Object buf
, val
;
619 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
620 temp_output_buffer_setup (bufname
);
621 buf
= Vstandard_output
;
624 val
= (*function
) (args
);
627 temp_output_buffer_show (buf
);
630 return unbind_to (count
, val
);
633 DEFUN ("with-output-to-temp-buffer",
634 Fwith_output_to_temp_buffer
, Swith_output_to_temp_buffer
,
636 doc
: /* Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
637 The buffer is cleared out initially, and marked as unmodified when done.
638 All output done by BODY is inserted in that buffer by default.
639 The buffer is displayed in another window, but not selected.
640 The value of the last form in BODY is returned.
641 If BODY does not finish normally, the buffer BUFNAME is not displayed.
643 The hook `temp-buffer-setup-hook' is run before BODY,
644 with the buffer BUFNAME temporarily current.
645 The hook `temp-buffer-show-hook' is run after the buffer is displayed,
646 with the buffer temporarily current, and the window that was used
647 to display it temporarily selected.
649 If variable `temp-buffer-show-function' is non-nil, call it at the end
650 to get the buffer displayed instead of just displaying the non-selected
651 buffer and calling the hook. It gets one argument, the buffer to display.
653 usage: (with-output-to-temp-buffer BUFFNAME BODY ...) */)
659 int count
= specpdl_ptr
- specpdl
;
660 Lisp_Object buf
, val
;
663 name
= Feval (Fcar (args
));
665 temp_output_buffer_setup (XSTRING (name
)->data
);
666 buf
= Vstandard_output
;
669 val
= Fprogn (XCDR (args
));
672 temp_output_buffer_show (buf
);
675 return unbind_to (count
, val
);
679 static void print ();
680 static void print_preprocess ();
681 static void print_preprocess_string ();
682 static void print_object ();
684 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
685 doc
: /* Output a newline to stream PRINTCHARFUN.
686 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
688 Lisp_Object printcharfun
;
692 if (NILP (printcharfun
))
693 printcharfun
= Vstandard_output
;
700 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
701 doc
: /* Output the printed representation of OBJECT, any Lisp object.
702 Quoting characters are printed when needed to make output that `read'
703 can handle, whenever this is possible. For complex objects, the behavior
704 is controlled by `print-level' and `print-length', which see.
706 OBJECT is any of the Lisp data types: a number, a string, a symbol,
707 a list, a buffer, a window, a frame, etc.
709 A printed representation of an object is text which describes that object.
711 Optional argument PRINTCHARFUN is the output stream, which can be one
714 - a buffer, in which case output is inserted into that buffer at point;
715 - a marker, in which case output is inserted at marker's position;
716 - a function, in which case that function is called once for each
717 character of OBJECT's printed representation;
718 - a symbol, in which case that symbol's function definition is called; or
719 - t, in which case the output is displayed in the echo area.
721 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
723 (object
, printcharfun
)
724 Lisp_Object object
, printcharfun
;
728 #ifdef MAX_PRINT_CHARS
730 #endif /* MAX_PRINT_CHARS */
731 if (NILP (printcharfun
))
732 printcharfun
= Vstandard_output
;
734 print (object
, printcharfun
, 1);
739 /* a buffer which is used to hold output being built by prin1-to-string */
740 Lisp_Object Vprin1_to_string_buffer
;
742 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
743 doc
: /* Return a string containing the printed representation of OBJECT.
744 OBJECT can be any Lisp object. This function outputs quoting characters
745 when necessary to make output that `read' can handle, whenever possible,
746 unless the optional second argument NOESCAPE is non-nil.
748 OBJECT is any of the Lisp data types: a number, a string, a symbol,
749 a list, a buffer, a window, a frame, etc.
751 A printed representation of an object is text which describes that object. */)
753 Lisp_Object object
, noescape
;
756 Lisp_Object printcharfun
;
757 struct gcpro gcpro1
, gcpro2
;
760 /* Save and restore this--we are altering a buffer
761 but we don't want to deactivate the mark just for that.
762 No need for specbind, since errors deactivate the mark. */
763 tem
= Vdeactivate_mark
;
764 GCPRO2 (object
, tem
);
766 printcharfun
= Vprin1_to_string_buffer
;
768 print (object
, printcharfun
, NILP (noescape
));
769 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
771 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
772 object
= Fbuffer_string ();
775 set_buffer_internal (old
);
777 Vdeactivate_mark
= tem
;
783 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
784 doc
: /* Output the printed representation of OBJECT, any Lisp object.
785 No quoting characters are used; no delimiters are printed around
786 the contents of strings.
788 OBJECT is any of the Lisp data types: a number, a string, a symbol,
789 a list, a buffer, a window, a frame, etc.
791 A printed representation of an object is text which describes that object.
793 Optional argument PRINTCHARFUN is the output stream, which can be one
796 - a buffer, in which case output is inserted into that buffer at point;
797 - a marker, in which case output is inserted at marker's position;
798 - a function, in which case that function is called once for each
799 character of OBJECT's printed representation;
800 - a symbol, in which case that symbol's function definition is called; or
801 - t, in which case the output is displayed in the echo area.
803 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
805 (object
, printcharfun
)
806 Lisp_Object object
, printcharfun
;
810 if (NILP (printcharfun
))
811 printcharfun
= Vstandard_output
;
813 print (object
, printcharfun
, 0);
818 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
819 doc
: /* Output the printed representation of OBJECT, with newlines around it.
820 Quoting characters are printed when needed to make output that `read'
821 can handle, whenever this is possible. For complex objects, the behavior
822 is controlled by `print-level' and `print-length', which see.
824 OBJECT is any of the Lisp data types: a number, a string, a symbol,
825 a list, a buffer, a window, a frame, etc.
827 A printed representation of an object is text which describes that object.
829 Optional argument PRINTCHARFUN is the output stream, which can be one
832 - a buffer, in which case output is inserted into that buffer at point;
833 - a marker, in which case output is inserted at marker's position;
834 - a function, in which case that function is called once for each
835 character of OBJECT's printed representation;
836 - a symbol, in which case that symbol's function definition is called; or
837 - t, in which case the output is displayed in the echo area.
839 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
841 (object
, printcharfun
)
842 Lisp_Object object
, printcharfun
;
847 #ifdef MAX_PRINT_CHARS
849 max_print
= MAX_PRINT_CHARS
;
850 #endif /* MAX_PRINT_CHARS */
851 if (NILP (printcharfun
))
852 printcharfun
= Vstandard_output
;
856 print (object
, printcharfun
, 1);
859 #ifdef MAX_PRINT_CHARS
862 #endif /* MAX_PRINT_CHARS */
867 /* The subroutine object for external-debugging-output is kept here
868 for the convenience of the debugger. */
869 Lisp_Object Qexternal_debugging_output
;
871 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
872 doc
: /* Write CHARACTER to stderr.
873 You can call print while debugging emacs, and pass it this function
874 to make it write to the debugging output. */)
876 Lisp_Object character
;
878 CHECK_NUMBER (character
);
879 putc (XINT (character
), stderr
);
882 /* Send the output to a debugger (nothing happens if there isn't one). */
884 char buf
[2] = {(char) XINT (character
), '\0'};
885 OutputDebugString (buf
);
892 /* This is the interface for debugging printing. */
898 Fprin1 (arg
, Qexternal_debugging_output
);
899 fprintf (stderr
, "\r\n");
902 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
904 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message. */)
908 struct buffer
*old
= current_buffer
;
912 /* If OBJ is (error STRING), just return STRING.
913 That is not only faster, it also avoids the need to allocate
914 space here when the error is due to memory full. */
915 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
916 && CONSP (XCDR (obj
))
917 && STRINGP (XCAR (XCDR (obj
)))
918 && NILP (XCDR (XCDR (obj
))))
919 return XCAR (XCDR (obj
));
921 print_error_message (obj
, Vprin1_to_string_buffer
);
923 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
924 value
= Fbuffer_string ();
928 set_buffer_internal (old
);
934 /* Print an error message for the error DATA onto Lisp output stream
935 STREAM (suitable for the print functions). */
938 print_error_message (data
, stream
)
939 Lisp_Object data
, stream
;
941 Lisp_Object errname
, errmsg
, file_error
, tail
;
945 errname
= Fcar (data
);
947 if (EQ (errname
, Qerror
))
952 errmsg
= Fcar (data
);
957 Lisp_Object error_conditions
;
958 errmsg
= Fget (errname
, Qerror_message
);
959 error_conditions
= Fget (errname
, Qerror_conditions
);
960 file_error
= Fmemq (Qfile_error
, error_conditions
);
963 /* Print an error message including the data items. */
965 tail
= Fcdr_safe (data
);
968 /* If we know from where the error was signaled, show it in
970 if (!NILP (Vsignaling_function
) && SYMBOLP (Vsignaling_function
))
972 char *name
= XSYMBOL (Vsignaling_function
)->name
->data
;
973 message_dolog (name
, strlen (name
), 0, 0);
974 message_dolog (": ", 2, 0, 0);
975 Vsignaling_function
= Qnil
;
978 /* For file-error, make error message by concatenating
979 all the data items. They are all strings. */
980 if (!NILP (file_error
) && CONSP (tail
))
981 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
983 if (STRINGP (errmsg
))
984 Fprinc (errmsg
, stream
);
986 write_string_1 ("peculiar error", -1, stream
);
988 for (i
= 0; CONSP (tail
); tail
= XCDR (tail
), i
++)
992 write_string_1 (i
? ", " : ": ", 2, stream
);
994 if (!NILP (file_error
) || EQ (errname
, Qend_of_file
))
995 Fprinc (obj
, stream
);
997 Fprin1 (obj
, stream
);
1006 * The buffer should be at least as large as the max string size of the
1007 * largest float, printed in the biggest notation. This is undoubtedly
1008 * 20d float_output_format, with the negative of the C-constant "HUGE"
1011 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
1013 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
1014 * case of -1e307 in 20d float_output_format. What is one to do (short of
1015 * re-writing _doprnt to be more sane)?
1020 float_to_string (buf
, data
)
1027 /* Check for plus infinity in a way that won't lose
1028 if there is no plus infinity. */
1029 if (data
== data
/ 2 && data
> 1.0)
1031 strcpy (buf
, "1.0e+INF");
1034 /* Likewise for minus infinity. */
1035 if (data
== data
/ 2 && data
< -1.0)
1037 strcpy (buf
, "-1.0e+INF");
1040 /* Check for NaN in a way that won't fail if there are no NaNs. */
1041 if (! (data
* 0.0 >= 0.0))
1043 /* Prepend "-" if the NaN's sign bit is negative.
1044 The sign bit of a double is the bit that is 1 in -0.0. */
1046 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
1048 u_minus_zero
.d
= - 0.0;
1049 for (i
= 0; i
< sizeof (double); i
++)
1050 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
1056 strcpy (buf
, "0.0e+NaN");
1060 if (NILP (Vfloat_output_format
)
1061 || !STRINGP (Vfloat_output_format
))
1064 /* Generate the fewest number of digits that represent the
1065 floating point value without losing information.
1066 The following method is simple but a bit slow.
1067 For ideas about speeding things up, please see:
1069 Guy L Steele Jr & Jon L White, How to print floating-point numbers
1070 accurately. SIGPLAN notices 25, 6 (June 1990), 112-126.
1072 Robert G Burger & R Kent Dybvig, Printing floating point numbers
1073 quickly and accurately, SIGPLAN notices 31, 5 (May 1996), 108-116. */
1075 width
= fabs (data
) < DBL_MIN
? 1 : DBL_DIG
;
1077 sprintf (buf
, "%.*g", width
, data
);
1078 while (width
++ < DOUBLE_DIGITS_BOUND
&& atof (buf
) != data
);
1080 else /* oink oink */
1082 /* Check that the spec we have is fully valid.
1083 This means not only valid for printf,
1084 but meant for floats, and reasonable. */
1085 cp
= XSTRING (Vfloat_output_format
)->data
;
1094 /* Check the width specification. */
1096 if ('0' <= *cp
&& *cp
<= '9')
1100 width
= (width
* 10) + (*cp
++ - '0');
1101 while (*cp
>= '0' && *cp
<= '9');
1103 /* A precision of zero is valid only for %f. */
1105 || (width
== 0 && *cp
!= 'f'))
1109 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1115 sprintf (buf
, XSTRING (Vfloat_output_format
)->data
, data
);
1118 /* Make sure there is a decimal point with digit after, or an
1119 exponent, so that the value is readable as a float. But don't do
1120 this with "%.0f"; it's valid for that not to produce a decimal
1121 point. Note that width can be 0 only for %.0f. */
1124 for (cp
= buf
; *cp
; cp
++)
1125 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1128 if (*cp
== '.' && cp
[1] == 0)
1145 print (obj
, printcharfun
, escapeflag
)
1147 register Lisp_Object printcharfun
;
1152 /* Reset print_number_index and Vprint_number_table only when
1153 the variable Vprint_continuous_numbering is nil. Otherwise,
1154 the values of these variables will be kept between several
1156 if (NILP (Vprint_continuous_numbering
))
1158 print_number_index
= 0;
1159 Vprint_number_table
= Qnil
;
1162 /* Construct Vprint_number_table for print-gensym and print-circle. */
1163 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1165 int i
, start
, index
;
1166 /* Construct Vprint_number_table. */
1167 start
= index
= print_number_index
;
1168 print_preprocess (obj
);
1169 /* Remove unnecessary objects, which appear only once in OBJ;
1170 that is, whose status is Qnil. */
1171 for (i
= start
; i
< print_number_index
; i
++)
1172 if (!NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1174 PRINT_NUMBER_OBJECT (Vprint_number_table
, index
)
1175 = PRINT_NUMBER_OBJECT (Vprint_number_table
, i
);
1176 /* Reset the status field for the next print step. Now this
1177 field means whether the object has already been printed. */
1178 PRINT_NUMBER_STATUS (Vprint_number_table
, index
) = Qnil
;
1181 print_number_index
= index
;
1184 print_object (obj
, printcharfun
, escapeflag
);
1187 /* Construct Vprint_number_table according to the structure of OBJ.
1188 OBJ itself and all its elements will be added to Vprint_number_table
1189 recursively if it is a list, vector, compiled function, char-table,
1190 string (its text properties will be traced), or a symbol that has
1191 no obarray (this is for the print-gensym feature).
1192 The status fields of Vprint_number_table mean whether each object appears
1193 more than once in OBJ: Qnil at the first time, and Qt after that . */
1195 print_preprocess (obj
)
1201 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1202 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
)
1203 || (! NILP (Vprint_gensym
)
1205 && !SYMBOL_INTERNED_P (obj
)))
1207 /* In case print-circle is nil and print-gensym is t,
1208 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1209 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1211 for (i
= 0; i
< print_number_index
; i
++)
1212 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
), obj
))
1214 /* OBJ appears more than once. Let's remember that. */
1215 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1219 /* OBJ is not yet recorded. Let's add to the table. */
1220 if (print_number_index
== 0)
1222 /* Initialize the table. */
1223 Vprint_number_table
= Fmake_vector (make_number (40), Qnil
);
1225 else if (XVECTOR (Vprint_number_table
)->size
== print_number_index
* 2)
1227 /* Reallocate the table. */
1228 int i
= print_number_index
* 4;
1229 Lisp_Object old_table
= Vprint_number_table
;
1230 Vprint_number_table
= Fmake_vector (make_number (i
), Qnil
);
1231 for (i
= 0; i
< print_number_index
; i
++)
1233 PRINT_NUMBER_OBJECT (Vprint_number_table
, i
)
1234 = PRINT_NUMBER_OBJECT (old_table
, i
);
1235 PRINT_NUMBER_STATUS (Vprint_number_table
, i
)
1236 = PRINT_NUMBER_STATUS (old_table
, i
);
1239 PRINT_NUMBER_OBJECT (Vprint_number_table
, print_number_index
) = obj
;
1240 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1241 always print the gensym with a number. This is a special for
1242 the lisp function byte-compile-output-docform. */
1243 if (!NILP (Vprint_continuous_numbering
)
1245 && !SYMBOL_INTERNED_P (obj
))
1246 PRINT_NUMBER_STATUS (Vprint_number_table
, print_number_index
) = Qt
;
1247 print_number_index
++;
1250 switch (XGCTYPE (obj
))
1253 /* A string may have text properties, which can be circular. */
1254 traverse_intervals_noorder (XSTRING (obj
)->intervals
,
1255 print_preprocess_string
, Qnil
);
1259 print_preprocess (XCAR (obj
));
1263 case Lisp_Vectorlike
:
1264 size
= XVECTOR (obj
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1265 for (i
= 0; i
< size
; i
++)
1266 print_preprocess (XVECTOR (obj
)->contents
[i
]);
1276 print_preprocess_string (interval
, arg
)
1280 print_preprocess (interval
->plist
);
1284 print_object (obj
, printcharfun
, escapeflag
)
1286 register Lisp_Object printcharfun
;
1293 /* Detect circularities and truncate them. */
1294 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1295 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
)
1296 || (! NILP (Vprint_gensym
)
1298 && !SYMBOL_INTERNED_P (obj
)))
1300 if (NILP (Vprint_circle
) && NILP (Vprint_gensym
))
1302 /* Simple but incomplete way. */
1304 for (i
= 0; i
< print_depth
; i
++)
1305 if (EQ (obj
, being_printed
[i
]))
1307 sprintf (buf
, "#%d", i
);
1308 strout (buf
, -1, -1, printcharfun
, 0);
1311 being_printed
[print_depth
] = obj
;
1315 /* With the print-circle feature. */
1317 for (i
= 0; i
< print_number_index
; i
++)
1318 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
), obj
))
1320 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1322 /* Add a prefix #n= if OBJ has not yet been printed;
1323 that is, its status field is nil. */
1324 sprintf (buf
, "#%d=", i
+ 1);
1325 strout (buf
, -1, -1, printcharfun
, 0);
1326 /* OBJ is going to be printed. Set the status to t. */
1327 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1332 /* Just print #n# if OBJ has already been printed. */
1333 sprintf (buf
, "#%d#", i
+ 1);
1334 strout (buf
, -1, -1, printcharfun
, 0);
1343 if (print_depth
> PRINT_CIRCLE
)
1344 error ("Apparently circular structure being printed");
1345 #ifdef MAX_PRINT_CHARS
1346 if (max_print
&& print_chars
> max_print
)
1351 #endif /* MAX_PRINT_CHARS */
1353 switch (XGCTYPE (obj
))
1356 if (sizeof (int) == sizeof (EMACS_INT
))
1357 sprintf (buf
, "%d", XINT (obj
));
1358 else if (sizeof (long) == sizeof (EMACS_INT
))
1359 sprintf (buf
, "%ld", (long) XINT (obj
));
1362 strout (buf
, -1, -1, printcharfun
, 0);
1367 char pigbuf
[350]; /* see comments in float_to_string */
1369 float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1370 strout (pigbuf
, -1, -1, printcharfun
, 0);
1376 print_string (obj
, printcharfun
);
1379 register int i
, i_byte
;
1380 struct gcpro gcpro1
;
1383 /* 1 means we must ensure that the next character we output
1384 cannot be taken as part of a hex character escape. */
1385 int need_nonhex
= 0;
1386 int multibyte
= STRING_MULTIBYTE (obj
);
1390 if (!NULL_INTERVAL_P (XSTRING (obj
)->intervals
))
1397 str
= XSTRING (obj
)->data
;
1398 size_byte
= STRING_BYTES (XSTRING (obj
));
1400 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1402 /* Here, we must convert each multi-byte form to the
1403 corresponding character code before handing it to PRINTCHAR. */
1409 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
,
1410 size_byte
- i_byte
, len
);
1418 if (c
== '\n' && print_escape_newlines
)
1423 else if (c
== '\f' && print_escape_newlines
)
1428 else if (multibyte
&& ! ASCII_BYTE_P (c
)
1429 && (print_escape_multibyte
|| CHAR_BYTE8_P (c
)))
1431 /* When multibyte is disabled,
1432 print multibyte string chars using hex escapes. */
1433 unsigned char outbuf
[50];
1435 if (CHAR_BYTE8_P (c
))
1436 sprintf (outbuf
, "\\%03o", CHAR_TO_BYTE8 (c
));
1438 sprintf (outbuf
, "\\x%04x", c
);
1439 strout (outbuf
, -1, -1, printcharfun
, 0);
1442 else if (! multibyte
1443 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1444 && print_escape_nonascii
)
1446 /* When printing in a multibyte buffer
1447 or when explicitly requested,
1448 print single-byte non-ASCII string chars
1449 using octal escapes. */
1450 unsigned char outbuf
[5];
1451 sprintf (outbuf
, "\\%03o", c
);
1452 strout (outbuf
, -1, -1, printcharfun
, 0);
1456 /* If we just had a hex escape, and this character
1457 could be taken as part of it,
1458 output `\ ' to prevent that. */
1462 if ((c
>= 'a' && c
<= 'f')
1463 || (c
>= 'A' && c
<= 'F')
1464 || (c
>= '0' && c
<= '9'))
1465 strout ("\\ ", -1, -1, printcharfun
, 0);
1468 if (c
== '\"' || c
== '\\')
1475 if (!NULL_INTERVAL_P (XSTRING (obj
)->intervals
))
1477 traverse_intervals (XSTRING (obj
)->intervals
,
1478 0, print_interval
, printcharfun
);
1488 register int confusing
;
1489 register unsigned char *p
= XSYMBOL (obj
)->name
->data
;
1490 register unsigned char *end
= p
+ STRING_BYTES (XSYMBOL (obj
)->name
);
1492 int i
, i_byte
, size_byte
;
1495 XSETSTRING (name
, XSYMBOL (obj
)->name
);
1497 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1500 /* If symbol name begins with a digit, and ends with a digit,
1501 and contains nothing but digits and `e', it could be treated
1502 as a number. So set CONFUSING.
1504 Symbols that contain periods could also be taken as numbers,
1505 but periods are always escaped, so we don't have to worry
1507 else if (*p
>= '0' && *p
<= '9'
1508 && end
[-1] >= '0' && end
[-1] <= '9')
1510 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1511 /* Needed for \2e10. */
1514 confusing
= (end
== p
);
1519 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1525 size_byte
= STRING_BYTES (XSTRING (name
));
1527 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1529 /* Here, we must convert each multi-byte form to the
1530 corresponding character code before handing it to PRINTCHAR. */
1531 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1536 if (c
== '\"' || c
== '\\' || c
== '\''
1537 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1538 || c
== ',' || c
=='.' || c
== '`'
1539 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1541 PRINTCHAR ('\\'), confusing
= 0;
1549 /* If deeper than spec'd depth, print placeholder. */
1550 if (INTEGERP (Vprint_level
)
1551 && print_depth
> XINT (Vprint_level
))
1552 strout ("...", -1, -1, printcharfun
, 0);
1553 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1554 && (EQ (XCAR (obj
), Qquote
)))
1557 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1559 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1560 && (EQ (XCAR (obj
), Qfunction
)))
1564 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1566 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1567 && ((EQ (XCAR (obj
), Qbackquote
)
1568 || EQ (XCAR (obj
), Qcomma
)
1569 || EQ (XCAR (obj
), Qcomma_at
)
1570 || EQ (XCAR (obj
), Qcomma_dot
))))
1572 print_object (XCAR (obj
), printcharfun
, 0);
1573 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1579 int print_length
, i
;
1580 Lisp_Object halftail
= obj
;
1582 /* Negative values of print-length are invalid in CL.
1583 Treat them like nil, as CMUCL does. */
1584 if (NATNUMP (Vprint_length
))
1585 print_length
= XFASTINT (Vprint_length
);
1592 /* Detect circular list. */
1593 if (NILP (Vprint_circle
))
1595 /* Simple but imcomplete way. */
1596 if (i
!= 0 && EQ (obj
, halftail
))
1598 sprintf (buf
, " . #%d", i
/ 2);
1599 strout (buf
, -1, -1, printcharfun
, 0);
1605 /* With the print-circle feature. */
1609 for (i
= 0; i
< print_number_index
; i
++)
1610 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
),
1613 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1615 strout (" . ", 3, 3, printcharfun
, 0);
1616 print_object (obj
, printcharfun
, escapeflag
);
1620 sprintf (buf
, " . #%d#", i
+ 1);
1621 strout (buf
, -1, -1, printcharfun
, 0);
1631 if (print_length
&& i
> print_length
)
1633 strout ("...", 3, 3, printcharfun
, 0);
1637 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1641 halftail
= XCDR (halftail
);
1645 /* OBJ non-nil here means it's the end of a dotted list. */
1648 strout (" . ", 3, 3, printcharfun
, 0);
1649 print_object (obj
, printcharfun
, escapeflag
);
1657 case Lisp_Vectorlike
:
1662 strout ("#<process ", -1, -1, printcharfun
, 0);
1663 print_string (XPROCESS (obj
)->name
, printcharfun
);
1667 print_string (XPROCESS (obj
)->name
, printcharfun
);
1669 else if (BOOL_VECTOR_P (obj
))
1672 register unsigned char c
;
1673 struct gcpro gcpro1
;
1675 = (XBOOL_VECTOR (obj
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1681 if (sizeof (int) == sizeof (EMACS_INT
))
1682 sprintf (buf
, "%d", XBOOL_VECTOR (obj
)->size
);
1683 else if (sizeof (long) == sizeof (EMACS_INT
))
1684 sprintf (buf
, "%ld", XBOOL_VECTOR (obj
)->size
);
1687 strout (buf
, -1, -1, printcharfun
, 0);
1690 /* Don't print more characters than the specified maximum.
1691 Negative values of print-length are invalid. Treat them
1692 like a print-length of nil. */
1693 if (NATNUMP (Vprint_length
)
1694 && XFASTINT (Vprint_length
) < size_in_chars
)
1695 size_in_chars
= XFASTINT (Vprint_length
);
1697 for (i
= 0; i
< size_in_chars
; i
++)
1700 c
= XBOOL_VECTOR (obj
)->data
[i
];
1701 if (! ASCII_BYTE_P (c
))
1703 sprintf (buf
, "\\%03o", c
);
1704 strout (buf
, -1, -1, printcharfun
, 0);
1706 else if (c
== '\n' && print_escape_newlines
)
1711 else if (c
== '\f' && print_escape_newlines
)
1718 if (c
== '\"' || c
== '\\')
1727 else if (SUBRP (obj
))
1729 strout ("#<subr ", -1, -1, printcharfun
, 0);
1730 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
, 0);
1733 else if (WINDOWP (obj
))
1735 strout ("#<window ", -1, -1, printcharfun
, 0);
1736 sprintf (buf
, "%d", XFASTINT (XWINDOW (obj
)->sequence_number
));
1737 strout (buf
, -1, -1, printcharfun
, 0);
1738 if (!NILP (XWINDOW (obj
)->buffer
))
1740 strout (" on ", -1, -1, printcharfun
, 0);
1741 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1745 else if (HASH_TABLE_P (obj
))
1747 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1748 strout ("#<hash-table", -1, -1, printcharfun
, 0);
1749 if (SYMBOLP (h
->test
))
1753 strout (XSYMBOL (h
->test
)->name
->data
, -1, -1, printcharfun
, 0);
1755 strout (XSYMBOL (h
->weak
)->name
->data
, -1, -1, printcharfun
, 0);
1757 sprintf (buf
, "%d/%d", XFASTINT (h
->count
),
1758 XVECTOR (h
->next
)->size
);
1759 strout (buf
, -1, -1, printcharfun
, 0);
1761 sprintf (buf
, " 0x%lx", (unsigned long) h
);
1762 strout (buf
, -1, -1, printcharfun
, 0);
1765 else if (BUFFERP (obj
))
1767 if (NILP (XBUFFER (obj
)->name
))
1768 strout ("#<killed buffer>", -1, -1, printcharfun
, 0);
1769 else if (escapeflag
)
1771 strout ("#<buffer ", -1, -1, printcharfun
, 0);
1772 print_string (XBUFFER (obj
)->name
, printcharfun
);
1776 print_string (XBUFFER (obj
)->name
, printcharfun
);
1778 else if (WINDOW_CONFIGURATIONP (obj
))
1780 strout ("#<window-configuration>", -1, -1, printcharfun
, 0);
1782 else if (FRAMEP (obj
))
1784 strout ((FRAME_LIVE_P (XFRAME (obj
))
1785 ? "#<frame " : "#<dead frame "),
1786 -1, -1, printcharfun
, 0);
1787 print_string (XFRAME (obj
)->name
, printcharfun
);
1788 sprintf (buf
, " 0x%lx\\ ", (unsigned long) (XFRAME (obj
)));
1789 strout (buf
, -1, -1, printcharfun
, 0);
1794 int size
= XVECTOR (obj
)->size
;
1795 if (COMPILEDP (obj
))
1798 size
&= PSEUDOVECTOR_SIZE_MASK
;
1800 if (CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
))
1802 /* We print a char-table as if it were a vector,
1803 lumping the parent and default slots in with the
1804 character slots. But we add #^ as a prefix. */
1807 if (SUB_CHAR_TABLE_P (obj
))
1809 size
&= PSEUDOVECTOR_SIZE_MASK
;
1811 if (size
& PSEUDOVECTOR_FLAG
)
1817 register Lisp_Object tem
;
1818 int real_size
= size
;
1820 /* Don't print more elements than the specified maximum. */
1821 if (NATNUMP (Vprint_length
)
1822 && XFASTINT (Vprint_length
) < size
)
1823 size
= XFASTINT (Vprint_length
);
1825 for (i
= 0; i
< size
; i
++)
1827 if (i
) PRINTCHAR (' ');
1828 tem
= XVECTOR (obj
)->contents
[i
];
1829 print_object (tem
, printcharfun
, escapeflag
);
1831 if (size
< real_size
)
1832 strout (" ...", 4, 4, printcharfun
, 0);
1839 switch (XMISCTYPE (obj
))
1841 case Lisp_Misc_Marker
:
1842 strout ("#<marker ", -1, -1, printcharfun
, 0);
1843 /* Do you think this is necessary? */
1844 if (XMARKER (obj
)->insertion_type
!= 0)
1845 strout ("(moves after insertion) ", -1, -1, printcharfun
, 0);
1846 if (!(XMARKER (obj
)->buffer
))
1847 strout ("in no buffer", -1, -1, printcharfun
, 0);
1850 sprintf (buf
, "at %d", marker_position (obj
));
1851 strout (buf
, -1, -1, printcharfun
, 0);
1852 strout (" in ", -1, -1, printcharfun
, 0);
1853 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
1858 case Lisp_Misc_Overlay
:
1859 strout ("#<overlay ", -1, -1, printcharfun
, 0);
1860 if (!(XMARKER (OVERLAY_START (obj
))->buffer
))
1861 strout ("in no buffer", -1, -1, printcharfun
, 0);
1864 sprintf (buf
, "from %d to %d in ",
1865 marker_position (OVERLAY_START (obj
)),
1866 marker_position (OVERLAY_END (obj
)));
1867 strout (buf
, -1, -1, printcharfun
, 0);
1868 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
1874 /* Remaining cases shouldn't happen in normal usage, but let's print
1875 them anyway for the benefit of the debugger. */
1876 case Lisp_Misc_Free
:
1877 strout ("#<misc free cell>", -1, -1, printcharfun
, 0);
1880 case Lisp_Misc_Intfwd
:
1881 sprintf (buf
, "#<intfwd to %d>", *XINTFWD (obj
)->intvar
);
1882 strout (buf
, -1, -1, printcharfun
, 0);
1885 case Lisp_Misc_Boolfwd
:
1886 sprintf (buf
, "#<boolfwd to %s>",
1887 (*XBOOLFWD (obj
)->boolvar
? "t" : "nil"));
1888 strout (buf
, -1, -1, printcharfun
, 0);
1891 case Lisp_Misc_Objfwd
:
1892 strout ("#<objfwd to ", -1, -1, printcharfun
, 0);
1893 print_object (*XOBJFWD (obj
)->objvar
, printcharfun
, escapeflag
);
1897 case Lisp_Misc_Buffer_Objfwd
:
1898 strout ("#<buffer_objfwd to ", -1, -1, printcharfun
, 0);
1899 print_object (PER_BUFFER_VALUE (current_buffer
,
1900 XBUFFER_OBJFWD (obj
)->offset
),
1901 printcharfun
, escapeflag
);
1905 case Lisp_Misc_Kboard_Objfwd
:
1906 strout ("#<kboard_objfwd to ", -1, -1, printcharfun
, 0);
1907 print_object (*(Lisp_Object
*)((char *) current_kboard
1908 + XKBOARD_OBJFWD (obj
)->offset
),
1909 printcharfun
, escapeflag
);
1913 case Lisp_Misc_Buffer_Local_Value
:
1914 strout ("#<buffer_local_value ", -1, -1, printcharfun
, 0);
1915 goto do_buffer_local
;
1916 case Lisp_Misc_Some_Buffer_Local_Value
:
1917 strout ("#<some_buffer_local_value ", -1, -1, printcharfun
, 0);
1919 strout ("[realvalue] ", -1, -1, printcharfun
, 0);
1920 print_object (XBUFFER_LOCAL_VALUE (obj
)->realvalue
,
1921 printcharfun
, escapeflag
);
1922 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_buffer
)
1923 strout ("[local in buffer] ", -1, -1, printcharfun
, 0);
1925 strout ("[buffer] ", -1, -1, printcharfun
, 0);
1926 print_object (XBUFFER_LOCAL_VALUE (obj
)->buffer
,
1927 printcharfun
, escapeflag
);
1928 if (XBUFFER_LOCAL_VALUE (obj
)->check_frame
)
1930 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_frame
)
1931 strout ("[local in frame] ", -1, -1, printcharfun
, 0);
1933 strout ("[frame] ", -1, -1, printcharfun
, 0);
1934 print_object (XBUFFER_LOCAL_VALUE (obj
)->frame
,
1935 printcharfun
, escapeflag
);
1937 strout ("[alist-elt] ", -1, -1, printcharfun
, 0);
1938 print_object (XCAR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
1939 printcharfun
, escapeflag
);
1940 strout ("[default-value] ", -1, -1, printcharfun
, 0);
1941 print_object (XCDR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
1942 printcharfun
, escapeflag
);
1954 /* We're in trouble if this happens!
1955 Probably should just abort () */
1956 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
, 0);
1958 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
1959 else if (VECTORLIKEP (obj
))
1960 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
1962 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
1963 strout (buf
, -1, -1, printcharfun
, 0);
1964 strout (" Save your buffers immediately and please report this bug>",
1965 -1, -1, printcharfun
, 0);
1973 /* Print a description of INTERVAL using PRINTCHARFUN.
1974 This is part of printing a string that has text properties. */
1977 print_interval (interval
, printcharfun
)
1979 Lisp_Object printcharfun
;
1982 print_object (make_number (interval
->position
), printcharfun
, 1);
1984 print_object (make_number (interval
->position
+ LENGTH (interval
)),
1987 print_object (interval
->plist
, printcharfun
, 1);
1994 Qtemp_buffer_setup_hook
= intern ("temp-buffer-setup-hook");
1995 staticpro (&Qtemp_buffer_setup_hook
);
1997 DEFVAR_LISP ("standard-output", &Vstandard_output
,
1998 doc
: /* Output stream `print' uses by default for outputting a character.
1999 This may be any function of one argument.
2000 It may also be a buffer (output is inserted before point)
2001 or a marker (output is inserted and the marker is advanced)
2002 or the symbol t (output appears in the echo area). */);
2003 Vstandard_output
= Qt
;
2004 Qstandard_output
= intern ("standard-output");
2005 staticpro (&Qstandard_output
);
2007 DEFVAR_LISP ("float-output-format", &Vfloat_output_format
,
2008 doc
: /* The format descriptor string used to print floats.
2009 This is a %-spec like those accepted by `printf' in C,
2010 but with some restrictions. It must start with the two characters `%.'.
2011 After that comes an integer precision specification,
2012 and then a letter which controls the format.
2013 The letters allowed are `e', `f' and `g'.
2014 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2015 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2016 Use `g' to choose the shorter of those two formats for the number at hand.
2017 The precision in any of these cases is the number of digits following
2018 the decimal point. With `f', a precision of 0 means to omit the
2019 decimal point. 0 is not allowed with `e' or `g'.
2021 A value of nil means to use the shortest notation
2022 that represents the number without losing information. */);
2023 Vfloat_output_format
= Qnil
;
2024 Qfloat_output_format
= intern ("float-output-format");
2025 staticpro (&Qfloat_output_format
);
2027 DEFVAR_LISP ("print-length", &Vprint_length
,
2028 doc
: /* Maximum length of list to print before abbreviating.
2029 A value of nil means no limit. See also `eval-expression-print-length'. */);
2030 Vprint_length
= Qnil
;
2032 DEFVAR_LISP ("print-level", &Vprint_level
,
2033 doc
: /* Maximum depth of list nesting to print before abbreviating.
2034 A value of nil means no limit. See also `eval-expression-print-level'. */);
2035 Vprint_level
= Qnil
;
2037 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines
,
2038 doc
: /* Non-nil means print newlines in strings as `\\n'.
2039 Also print formfeeds as `\\f'. */);
2040 print_escape_newlines
= 0;
2042 DEFVAR_BOOL ("print-escape-nonascii", &print_escape_nonascii
,
2043 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2044 \(OOO is the octal representation of the character code.)
2045 Only single-byte characters are affected, and only in `prin1'. */);
2046 print_escape_nonascii
= 0;
2048 DEFVAR_BOOL ("print-escape-multibyte", &print_escape_multibyte
,
2049 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2050 \(XXXX is the hex representation of the character code.)
2051 This affects only `prin1'. */);
2052 print_escape_multibyte
= 0;
2054 DEFVAR_BOOL ("print-quoted", &print_quoted
,
2055 doc
: /* Non-nil means print quoted forms with reader syntax.
2056 I.e., (quote foo) prints as 'foo, (function foo) as #'foo, and backquoted
2057 forms print as in the new syntax. */);
2060 DEFVAR_LISP ("print-gensym", &Vprint_gensym
,
2061 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2062 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2063 When the uninterned symbol appears within a recursive data structure,
2064 and the symbol appears more than once, in addition use the #N# and #N=
2065 constructs as needed, so that multiple references to the same symbol are
2066 shared once again when the text is read back. */);
2067 Vprint_gensym
= Qnil
;
2069 DEFVAR_LISP ("print-circle", &Vprint_circle
,
2070 doc
: /* *Non-nil means print recursive structures using #N= and #N# syntax.
2071 If nil, printing proceeds recursively and may lead to
2072 `max-lisp-eval-depth' being exceeded or an error may occur:
2073 \"Apparently circular structure being printed.\" Also see
2074 `print-length' and `print-level'.
2075 If non-nil, shared substructures anywhere in the structure are printed
2076 with `#N=' before the first occurrence (in the order of the print
2077 representation) and `#N#' in place of each subsequent occurrence,
2078 where N is a positive decimal integer. */);
2079 Vprint_circle
= Qnil
;
2081 DEFVAR_LISP ("print-continuous-numbering", &Vprint_continuous_numbering
,
2082 doc
: /* *Non-nil means number continuously across print calls.
2083 This affects the numbers printed for #N= labels and #M# references.
2084 See also `print-circle', `print-gensym', and `print-number-table'.
2085 This variable should not be set with `setq'; bind it with a `let' instead. */);
2086 Vprint_continuous_numbering
= Qnil
;
2088 DEFVAR_LISP ("print-number-table", &Vprint_number_table
,
2089 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2090 The Lisp printer uses this vector to detect Lisp objects referenced more
2091 than once. When `print-continuous-numbering' is bound to t, you should
2092 probably also bind `print-number-table' to nil. This ensures that the
2093 value of `print-number-table' can be garbage-collected once the printing
2095 Vprint_number_table
= Qnil
;
2097 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2098 staticpro (&Vprin1_to_string_buffer
);
2101 defsubr (&Sprin1_to_string
);
2102 defsubr (&Serror_message_string
);
2106 defsubr (&Swrite_char
);
2107 defsubr (&Sexternal_debugging_output
);
2109 Qexternal_debugging_output
= intern ("external-debugging-output");
2110 staticpro (&Qexternal_debugging_output
);
2112 Qprint_escape_newlines
= intern ("print-escape-newlines");
2113 staticpro (&Qprint_escape_newlines
);
2115 Qprint_escape_multibyte
= intern ("print-escape-multibyte");
2116 staticpro (&Qprint_escape_multibyte
);
2118 Qprint_escape_nonascii
= intern ("print-escape-nonascii");
2119 staticpro (&Qprint_escape_nonascii
);
2121 defsubr (&Swith_output_to_temp_buffer
);