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. */
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_INDEX (); \
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 (SDATA (saved_text
), print_buffer
, SCHARS (saved_text
));
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 (STRING_MULTIBYTE (string
))
464 chars
= SCHARS (string
);
465 else if (EQ (printcharfun
, Qt
)
466 ? ! NILP (buffer_defaults
.enable_multibyte_characters
)
467 : ! NILP (current_buffer
->enable_multibyte_characters
))
469 /* If unibyte string STRING contains 8-bit codes, we must
470 convert STRING to a multibyte string containing the same
475 chars
= SBYTES (string
);
476 bytes
= parse_str_to_multibyte (SDATA (string
), chars
);
479 newstr
= make_uninit_multibyte_string (chars
, bytes
);
480 bcopy (SDATA (string
), SDATA (newstr
), chars
);
481 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
486 chars
= SBYTES (string
);
488 /* strout is safe for output to a frame (echo area) or to print_buffer. */
489 strout (SDATA (string
),
490 chars
, SBYTES (string
),
491 printcharfun
, STRING_MULTIBYTE (string
));
495 /* Otherwise, string may be relocated by printing one char.
496 So re-fetch the string address for each character. */
498 int size
= SCHARS (string
);
499 int size_byte
= SBYTES (string
);
502 if (size
== size_byte
)
503 for (i
= 0; i
< size
; i
++)
504 PRINTCHAR (SREF (string
, i
));
506 for (i
= 0; i
< size_byte
; i
++)
508 /* Here, we must convert each multi-byte form to the
509 corresponding character code before handing it to PRINTCHAR. */
511 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
,
513 if (!CHAR_VALID_P (ch
, 0))
515 ch
= SREF (string
, i
);
525 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
526 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
527 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
528 (character
, printcharfun
)
529 Lisp_Object character
, printcharfun
;
533 if (NILP (printcharfun
))
534 printcharfun
= Vstandard_output
;
535 CHECK_NUMBER (character
);
537 PRINTCHAR (XINT (character
));
542 /* Used from outside of print.c to print a block of SIZE
543 single-byte chars at DATA on the default output stream.
544 Do not use this on the contents of a Lisp string. */
547 write_string (data
, size
)
552 Lisp_Object printcharfun
;
554 printcharfun
= Vstandard_output
;
557 strout (data
, size
, size
, printcharfun
, 0);
561 /* Used from outside of print.c to print a block of SIZE
562 single-byte chars at DATA on a specified stream PRINTCHARFUN.
563 Do not use this on the contents of a Lisp string. */
566 write_string_1 (data
, size
, printcharfun
)
569 Lisp_Object printcharfun
;
574 strout (data
, size
, size
, printcharfun
, 0);
580 temp_output_buffer_setup (bufname
)
583 int count
= SPECPDL_INDEX ();
584 register struct buffer
*old
= current_buffer
;
585 register Lisp_Object buf
;
587 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
589 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
591 Fkill_all_local_variables ();
592 current_buffer
->directory
= old
->directory
;
593 current_buffer
->read_only
= Qnil
;
594 current_buffer
->filename
= Qnil
;
595 current_buffer
->undo_list
= Qt
;
596 current_buffer
->overlays_before
= Qnil
;
597 current_buffer
->overlays_after
= Qnil
;
598 current_buffer
->enable_multibyte_characters
599 = buffer_defaults
.enable_multibyte_characters
;
601 XSETBUFFER (buf
, current_buffer
);
603 Frun_hooks (1, &Qtemp_buffer_setup_hook
);
605 unbind_to (count
, Qnil
);
607 specbind (Qstandard_output
, buf
);
611 internal_with_output_to_temp_buffer (bufname
, function
, args
)
613 Lisp_Object (*function
) P_ ((Lisp_Object
));
616 int count
= SPECPDL_INDEX ();
617 Lisp_Object buf
, val
;
621 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
622 temp_output_buffer_setup (bufname
);
623 buf
= Vstandard_output
;
626 val
= (*function
) (args
);
629 temp_output_buffer_show (buf
);
632 return unbind_to (count
, val
);
635 DEFUN ("with-output-to-temp-buffer",
636 Fwith_output_to_temp_buffer
, Swith_output_to_temp_buffer
,
638 doc
: /* Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
639 The buffer is cleared out initially, and marked as unmodified when done.
640 All output done by BODY is inserted in that buffer by default.
641 The buffer is displayed in another window, but not selected.
642 The value of the last form in BODY is returned.
643 If BODY does not finish normally, the buffer BUFNAME is not displayed.
645 The hook `temp-buffer-setup-hook' is run before BODY,
646 with the buffer BUFNAME temporarily current.
647 The hook `temp-buffer-show-hook' is run after the buffer is displayed,
648 with the buffer temporarily current, and the window that was used
649 to display it temporarily selected.
651 If variable `temp-buffer-show-function' is non-nil, call it at the end
652 to get the buffer displayed instead of just displaying the non-selected
653 buffer and calling the hook. It gets one argument, the buffer to display.
655 usage: (with-output-to-temp-buffer BUFFNAME BODY ...) */)
661 int count
= SPECPDL_INDEX ();
662 Lisp_Object buf
, val
;
665 name
= Feval (Fcar (args
));
667 temp_output_buffer_setup (SDATA (name
));
668 buf
= Vstandard_output
;
671 val
= Fprogn (XCDR (args
));
674 temp_output_buffer_show (buf
);
677 return unbind_to (count
, val
);
681 static void print ();
682 static void print_preprocess ();
683 static void print_preprocess_string ();
684 static void print_object ();
686 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
687 doc
: /* Output a newline to stream PRINTCHARFUN.
688 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
690 Lisp_Object printcharfun
;
694 if (NILP (printcharfun
))
695 printcharfun
= Vstandard_output
;
702 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
703 doc
: /* Output the printed representation of OBJECT, any Lisp object.
704 Quoting characters are printed when needed to make output that `read'
705 can handle, whenever this is possible. For complex objects, the behavior
706 is controlled by `print-level' and `print-length', which see.
708 OBJECT is any of the Lisp data types: a number, a string, a symbol,
709 a list, a buffer, a window, a frame, etc.
711 A printed representation of an object is text which describes that object.
713 Optional argument PRINTCHARFUN is the output stream, which can be one
716 - a buffer, in which case output is inserted into that buffer at point;
717 - a marker, in which case output is inserted at marker's position;
718 - a function, in which case that function is called once for each
719 character of OBJECT's printed representation;
720 - a symbol, in which case that symbol's function definition is called; or
721 - t, in which case the output is displayed in the echo area.
723 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
725 (object
, printcharfun
)
726 Lisp_Object object
, printcharfun
;
730 #ifdef MAX_PRINT_CHARS
732 #endif /* MAX_PRINT_CHARS */
733 if (NILP (printcharfun
))
734 printcharfun
= Vstandard_output
;
736 print (object
, printcharfun
, 1);
741 /* a buffer which is used to hold output being built by prin1-to-string */
742 Lisp_Object Vprin1_to_string_buffer
;
744 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
745 doc
: /* Return a string containing the printed representation of OBJECT.
746 OBJECT can be any Lisp object. This function outputs quoting characters
747 when necessary to make output that `read' can handle, whenever possible,
748 unless the optional second argument NOESCAPE is non-nil.
750 OBJECT is any of the Lisp data types: a number, a string, a symbol,
751 a list, a buffer, a window, a frame, etc.
753 A printed representation of an object is text which describes that object. */)
755 Lisp_Object object
, noescape
;
758 Lisp_Object printcharfun
;
759 struct gcpro gcpro1
, gcpro2
;
762 /* Save and restore this--we are altering a buffer
763 but we don't want to deactivate the mark just for that.
764 No need for specbind, since errors deactivate the mark. */
765 tem
= Vdeactivate_mark
;
766 GCPRO2 (object
, tem
);
768 printcharfun
= Vprin1_to_string_buffer
;
770 print (object
, printcharfun
, NILP (noescape
));
771 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
773 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
774 object
= Fbuffer_string ();
777 set_buffer_internal (old
);
779 Vdeactivate_mark
= tem
;
785 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
786 doc
: /* Output the printed representation of OBJECT, any Lisp object.
787 No quoting characters are used; no delimiters are printed around
788 the contents of strings.
790 OBJECT is any of the Lisp data types: a number, a string, a symbol,
791 a list, a buffer, a window, a frame, etc.
793 A printed representation of an object is text which describes that object.
795 Optional argument PRINTCHARFUN is the output stream, which can be one
798 - a buffer, in which case output is inserted into that buffer at point;
799 - a marker, in which case output is inserted at marker's position;
800 - a function, in which case that function is called once for each
801 character of OBJECT's printed representation;
802 - a symbol, in which case that symbol's function definition is called; or
803 - t, in which case the output is displayed in the echo area.
805 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
807 (object
, printcharfun
)
808 Lisp_Object object
, printcharfun
;
812 if (NILP (printcharfun
))
813 printcharfun
= Vstandard_output
;
815 print (object
, printcharfun
, 0);
820 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
821 doc
: /* Output the printed representation of OBJECT, with newlines around it.
822 Quoting characters are printed when needed to make output that `read'
823 can handle, whenever this is possible. For complex objects, the behavior
824 is controlled by `print-level' and `print-length', which see.
826 OBJECT is any of the Lisp data types: a number, a string, a symbol,
827 a list, a buffer, a window, a frame, etc.
829 A printed representation of an object is text which describes that object.
831 Optional argument PRINTCHARFUN is the output stream, which can be one
834 - a buffer, in which case output is inserted into that buffer at point;
835 - a marker, in which case output is inserted at marker's position;
836 - a function, in which case that function is called once for each
837 character of OBJECT's printed representation;
838 - a symbol, in which case that symbol's function definition is called; or
839 - t, in which case the output is displayed in the echo area.
841 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
843 (object
, printcharfun
)
844 Lisp_Object object
, printcharfun
;
849 #ifdef MAX_PRINT_CHARS
851 max_print
= MAX_PRINT_CHARS
;
852 #endif /* MAX_PRINT_CHARS */
853 if (NILP (printcharfun
))
854 printcharfun
= Vstandard_output
;
858 print (object
, printcharfun
, 1);
861 #ifdef MAX_PRINT_CHARS
864 #endif /* MAX_PRINT_CHARS */
869 /* The subroutine object for external-debugging-output is kept here
870 for the convenience of the debugger. */
871 Lisp_Object Qexternal_debugging_output
;
873 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
874 doc
: /* Write CHARACTER to stderr.
875 You can call print while debugging emacs, and pass it this function
876 to make it write to the debugging output. */)
878 Lisp_Object character
;
880 CHECK_NUMBER (character
);
881 putc (XINT (character
), stderr
);
884 /* Send the output to a debugger (nothing happens if there isn't one). */
886 char buf
[2] = {(char) XINT (character
), '\0'};
887 OutputDebugString (buf
);
894 /* This is the interface for debugging printing. */
900 Fprin1 (arg
, Qexternal_debugging_output
);
901 fprintf (stderr
, "\r\n");
904 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
906 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message. */)
910 struct buffer
*old
= current_buffer
;
914 /* If OBJ is (error STRING), just return STRING.
915 That is not only faster, it also avoids the need to allocate
916 space here when the error is due to memory full. */
917 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
918 && CONSP (XCDR (obj
))
919 && STRINGP (XCAR (XCDR (obj
)))
920 && NILP (XCDR (XCDR (obj
))))
921 return XCAR (XCDR (obj
));
923 print_error_message (obj
, Vprin1_to_string_buffer
);
925 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
926 value
= Fbuffer_string ();
930 set_buffer_internal (old
);
936 /* Print an error message for the error DATA onto Lisp output stream
937 STREAM (suitable for the print functions). */
940 print_error_message (data
, stream
)
941 Lisp_Object data
, stream
;
943 Lisp_Object errname
, errmsg
, file_error
, tail
;
947 errname
= Fcar (data
);
949 if (EQ (errname
, Qerror
))
954 errmsg
= Fcar (data
);
959 Lisp_Object error_conditions
;
960 errmsg
= Fget (errname
, Qerror_message
);
961 error_conditions
= Fget (errname
, Qerror_conditions
);
962 file_error
= Fmemq (Qfile_error
, error_conditions
);
965 /* Print an error message including the data items. */
967 tail
= Fcdr_safe (data
);
970 /* For file-error, make error message by concatenating
971 all the data items. They are all strings. */
972 if (!NILP (file_error
) && CONSP (tail
))
973 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
975 if (STRINGP (errmsg
))
976 Fprinc (errmsg
, stream
);
978 write_string_1 ("peculiar error", -1, stream
);
980 for (i
= 0; CONSP (tail
); tail
= XCDR (tail
), i
++)
984 write_string_1 (i
? ", " : ": ", 2, stream
);
986 if (!NILP (file_error
) || EQ (errname
, Qend_of_file
))
987 Fprinc (obj
, stream
);
989 Fprin1 (obj
, stream
);
998 * The buffer should be at least as large as the max string size of the
999 * largest float, printed in the biggest notation. This is undoubtedly
1000 * 20d float_output_format, with the negative of the C-constant "HUGE"
1003 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
1005 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
1006 * case of -1e307 in 20d float_output_format. What is one to do (short of
1007 * re-writing _doprnt to be more sane)?
1012 float_to_string (buf
, data
)
1019 /* Check for plus infinity in a way that won't lose
1020 if there is no plus infinity. */
1021 if (data
== data
/ 2 && data
> 1.0)
1023 strcpy (buf
, "1.0e+INF");
1026 /* Likewise for minus infinity. */
1027 if (data
== data
/ 2 && data
< -1.0)
1029 strcpy (buf
, "-1.0e+INF");
1032 /* Check for NaN in a way that won't fail if there are no NaNs. */
1033 if (! (data
* 0.0 >= 0.0))
1035 /* Prepend "-" if the NaN's sign bit is negative.
1036 The sign bit of a double is the bit that is 1 in -0.0. */
1038 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
1040 u_minus_zero
.d
= - 0.0;
1041 for (i
= 0; i
< sizeof (double); i
++)
1042 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
1048 strcpy (buf
, "0.0e+NaN");
1052 if (NILP (Vfloat_output_format
)
1053 || !STRINGP (Vfloat_output_format
))
1056 /* Generate the fewest number of digits that represent the
1057 floating point value without losing information.
1058 The following method is simple but a bit slow.
1059 For ideas about speeding things up, please see:
1061 Guy L Steele Jr & Jon L White, How to print floating-point numbers
1062 accurately. SIGPLAN notices 25, 6 (June 1990), 112-126.
1064 Robert G Burger & R Kent Dybvig, Printing floating point numbers
1065 quickly and accurately, SIGPLAN notices 31, 5 (May 1996), 108-116. */
1067 width
= fabs (data
) < DBL_MIN
? 1 : DBL_DIG
;
1069 sprintf (buf
, "%.*g", width
, data
);
1070 while (width
++ < DOUBLE_DIGITS_BOUND
&& atof (buf
) != data
);
1072 else /* oink oink */
1074 /* Check that the spec we have is fully valid.
1075 This means not only valid for printf,
1076 but meant for floats, and reasonable. */
1077 cp
= SDATA (Vfloat_output_format
);
1086 /* Check the width specification. */
1088 if ('0' <= *cp
&& *cp
<= '9')
1092 width
= (width
* 10) + (*cp
++ - '0');
1093 while (*cp
>= '0' && *cp
<= '9');
1095 /* A precision of zero is valid only for %f. */
1097 || (width
== 0 && *cp
!= 'f'))
1101 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1107 sprintf (buf
, SDATA (Vfloat_output_format
), data
);
1110 /* Make sure there is a decimal point with digit after, or an
1111 exponent, so that the value is readable as a float. But don't do
1112 this with "%.0f"; it's valid for that not to produce a decimal
1113 point. Note that width can be 0 only for %.0f. */
1116 for (cp
= buf
; *cp
; cp
++)
1117 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1120 if (*cp
== '.' && cp
[1] == 0)
1137 print (obj
, printcharfun
, escapeflag
)
1139 register Lisp_Object printcharfun
;
1144 /* Reset print_number_index and Vprint_number_table only when
1145 the variable Vprint_continuous_numbering is nil. Otherwise,
1146 the values of these variables will be kept between several
1148 if (NILP (Vprint_continuous_numbering
))
1150 print_number_index
= 0;
1151 Vprint_number_table
= Qnil
;
1154 /* Construct Vprint_number_table for print-gensym and print-circle. */
1155 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1157 int i
, start
, index
;
1158 /* Construct Vprint_number_table. */
1159 start
= index
= print_number_index
;
1160 print_preprocess (obj
);
1161 /* Remove unnecessary objects, which appear only once in OBJ;
1162 that is, whose status is Qnil. */
1163 for (i
= start
; i
< print_number_index
; i
++)
1164 if (!NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1166 PRINT_NUMBER_OBJECT (Vprint_number_table
, index
)
1167 = PRINT_NUMBER_OBJECT (Vprint_number_table
, i
);
1168 /* Reset the status field for the next print step. Now this
1169 field means whether the object has already been printed. */
1170 PRINT_NUMBER_STATUS (Vprint_number_table
, index
) = Qnil
;
1173 print_number_index
= index
;
1176 print_object (obj
, printcharfun
, escapeflag
);
1179 /* Construct Vprint_number_table according to the structure of OBJ.
1180 OBJ itself and all its elements will be added to Vprint_number_table
1181 recursively if it is a list, vector, compiled function, char-table,
1182 string (its text properties will be traced), or a symbol that has
1183 no obarray (this is for the print-gensym feature).
1184 The status fields of Vprint_number_table mean whether each object appears
1185 more than once in OBJ: Qnil at the first time, and Qt after that . */
1187 print_preprocess (obj
)
1193 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1194 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
)
1195 || (! NILP (Vprint_gensym
)
1197 && !SYMBOL_INTERNED_P (obj
)))
1199 /* In case print-circle is nil and print-gensym is t,
1200 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1201 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1203 for (i
= 0; i
< print_number_index
; i
++)
1204 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
), obj
))
1206 /* OBJ appears more than once. Let's remember that. */
1207 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1211 /* OBJ is not yet recorded. Let's add to the table. */
1212 if (print_number_index
== 0)
1214 /* Initialize the table. */
1215 Vprint_number_table
= Fmake_vector (make_number (40), Qnil
);
1217 else if (XVECTOR (Vprint_number_table
)->size
== print_number_index
* 2)
1219 /* Reallocate the table. */
1220 int i
= print_number_index
* 4;
1221 Lisp_Object old_table
= Vprint_number_table
;
1222 Vprint_number_table
= Fmake_vector (make_number (i
), Qnil
);
1223 for (i
= 0; i
< print_number_index
; i
++)
1225 PRINT_NUMBER_OBJECT (Vprint_number_table
, i
)
1226 = PRINT_NUMBER_OBJECT (old_table
, i
);
1227 PRINT_NUMBER_STATUS (Vprint_number_table
, i
)
1228 = PRINT_NUMBER_STATUS (old_table
, i
);
1231 PRINT_NUMBER_OBJECT (Vprint_number_table
, print_number_index
) = obj
;
1232 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1233 always print the gensym with a number. This is a special for
1234 the lisp function byte-compile-output-docform. */
1235 if (!NILP (Vprint_continuous_numbering
)
1237 && !SYMBOL_INTERNED_P (obj
))
1238 PRINT_NUMBER_STATUS (Vprint_number_table
, print_number_index
) = Qt
;
1239 print_number_index
++;
1242 switch (XGCTYPE (obj
))
1245 /* A string may have text properties, which can be circular. */
1246 traverse_intervals_noorder (STRING_INTERVALS (obj
),
1247 print_preprocess_string
, Qnil
);
1251 print_preprocess (XCAR (obj
));
1255 case Lisp_Vectorlike
:
1256 size
= XVECTOR (obj
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1257 for (i
= 0; i
< size
; i
++)
1258 print_preprocess (XVECTOR (obj
)->contents
[i
]);
1268 print_preprocess_string (interval
, arg
)
1272 print_preprocess (interval
->plist
);
1276 print_object (obj
, printcharfun
, escapeflag
)
1278 register Lisp_Object printcharfun
;
1285 /* Detect circularities and truncate them. */
1286 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1287 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
)
1288 || (! NILP (Vprint_gensym
)
1290 && !SYMBOL_INTERNED_P (obj
)))
1292 if (NILP (Vprint_circle
) && NILP (Vprint_gensym
))
1294 /* Simple but incomplete way. */
1296 for (i
= 0; i
< print_depth
; i
++)
1297 if (EQ (obj
, being_printed
[i
]))
1299 sprintf (buf
, "#%d", i
);
1300 strout (buf
, -1, -1, printcharfun
, 0);
1303 being_printed
[print_depth
] = obj
;
1307 /* With the print-circle feature. */
1309 for (i
= 0; i
< print_number_index
; i
++)
1310 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
), obj
))
1312 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1314 /* Add a prefix #n= if OBJ has not yet been printed;
1315 that is, its status field is nil. */
1316 sprintf (buf
, "#%d=", i
+ 1);
1317 strout (buf
, -1, -1, printcharfun
, 0);
1318 /* OBJ is going to be printed. Set the status to t. */
1319 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1324 /* Just print #n# if OBJ has already been printed. */
1325 sprintf (buf
, "#%d#", i
+ 1);
1326 strout (buf
, -1, -1, printcharfun
, 0);
1335 if (print_depth
> PRINT_CIRCLE
)
1336 error ("Apparently circular structure being printed");
1337 #ifdef MAX_PRINT_CHARS
1338 if (max_print
&& print_chars
> max_print
)
1343 #endif /* MAX_PRINT_CHARS */
1345 switch (XGCTYPE (obj
))
1348 if (sizeof (int) == sizeof (EMACS_INT
))
1349 sprintf (buf
, "%d", XINT (obj
));
1350 else if (sizeof (long) == sizeof (EMACS_INT
))
1351 sprintf (buf
, "%ld", (long) XINT (obj
));
1354 strout (buf
, -1, -1, printcharfun
, 0);
1359 char pigbuf
[350]; /* see comments in float_to_string */
1361 float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1362 strout (pigbuf
, -1, -1, printcharfun
, 0);
1368 print_string (obj
, printcharfun
);
1371 register int i
, i_byte
;
1372 struct gcpro gcpro1
;
1375 /* 1 means we must ensure that the next character we output
1376 cannot be taken as part of a hex character escape. */
1377 int need_nonhex
= 0;
1378 int multibyte
= STRING_MULTIBYTE (obj
);
1382 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1390 size_byte
= SBYTES (obj
);
1392 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1394 /* Here, we must convert each multi-byte form to the
1395 corresponding character code before handing it to PRINTCHAR. */
1401 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
,
1402 size_byte
- i_byte
, len
);
1403 if (CHAR_VALID_P (c
, 0))
1413 if (c
== '\n' && print_escape_newlines
)
1418 else if (c
== '\f' && print_escape_newlines
)
1424 && ! ASCII_BYTE_P (c
)
1425 && (SINGLE_BYTE_CHAR_P (c
) || print_escape_multibyte
))
1427 /* When multibyte is disabled,
1428 print multibyte string chars using hex escapes.
1429 For a char code that could be in a unibyte string,
1430 when found in a multibyte string, always use a hex escape
1431 so it reads back as multibyte. */
1432 unsigned char outbuf
[50];
1433 sprintf (outbuf
, "\\x%x", c
);
1434 strout (outbuf
, -1, -1, printcharfun
, 0);
1437 else if (! multibyte
1438 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1439 && print_escape_nonascii
)
1441 /* When printing in a multibyte buffer
1442 or when explicitly requested,
1443 print single-byte non-ASCII string chars
1444 using octal escapes. */
1445 unsigned char outbuf
[5];
1446 sprintf (outbuf
, "\\%03o", c
);
1447 strout (outbuf
, -1, -1, printcharfun
, 0);
1451 /* If we just had a hex escape, and this character
1452 could be taken as part of it,
1453 output `\ ' to prevent that. */
1457 if ((c
>= 'a' && c
<= 'f')
1458 || (c
>= 'A' && c
<= 'F')
1459 || (c
>= '0' && c
<= '9'))
1460 strout ("\\ ", -1, -1, printcharfun
, 0);
1463 if (c
== '\"' || c
== '\\')
1470 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1472 traverse_intervals (STRING_INTERVALS (obj
),
1473 0, print_interval
, printcharfun
);
1483 register int confusing
;
1484 register unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1485 register unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1487 int i
, i_byte
, size_byte
;
1490 name
= SYMBOL_NAME (obj
);
1492 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1495 /* If symbol name begins with a digit, and ends with a digit,
1496 and contains nothing but digits and `e', it could be treated
1497 as a number. So set CONFUSING.
1499 Symbols that contain periods could also be taken as numbers,
1500 but periods are always escaped, so we don't have to worry
1502 else if (*p
>= '0' && *p
<= '9'
1503 && end
[-1] >= '0' && end
[-1] <= '9')
1505 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1506 /* Needed for \2e10. */
1509 confusing
= (end
== p
);
1514 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1520 size_byte
= SBYTES (name
);
1522 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1524 /* Here, we must convert each multi-byte form to the
1525 corresponding character code before handing it to PRINTCHAR. */
1526 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1531 if (c
== '\"' || c
== '\\' || c
== '\''
1532 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1533 || c
== ',' || c
=='.' || c
== '`'
1534 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1536 PRINTCHAR ('\\'), confusing
= 0;
1544 /* If deeper than spec'd depth, print placeholder. */
1545 if (INTEGERP (Vprint_level
)
1546 && print_depth
> XINT (Vprint_level
))
1547 strout ("...", -1, -1, printcharfun
, 0);
1548 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1549 && (EQ (XCAR (obj
), Qquote
)))
1552 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1554 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1555 && (EQ (XCAR (obj
), Qfunction
)))
1559 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1561 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1562 && ((EQ (XCAR (obj
), Qbackquote
)
1563 || EQ (XCAR (obj
), Qcomma
)
1564 || EQ (XCAR (obj
), Qcomma_at
)
1565 || EQ (XCAR (obj
), Qcomma_dot
))))
1567 print_object (XCAR (obj
), printcharfun
, 0);
1568 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1574 int print_length
, i
;
1575 Lisp_Object halftail
= obj
;
1577 /* Negative values of print-length are invalid in CL.
1578 Treat them like nil, as CMUCL does. */
1579 if (NATNUMP (Vprint_length
))
1580 print_length
= XFASTINT (Vprint_length
);
1587 /* Detect circular list. */
1588 if (NILP (Vprint_circle
))
1590 /* Simple but imcomplete way. */
1591 if (i
!= 0 && EQ (obj
, halftail
))
1593 sprintf (buf
, " . #%d", i
/ 2);
1594 strout (buf
, -1, -1, printcharfun
, 0);
1600 /* With the print-circle feature. */
1604 for (i
= 0; i
< print_number_index
; i
++)
1605 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
),
1608 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1610 strout (" . ", 3, 3, printcharfun
, 0);
1611 print_object (obj
, printcharfun
, escapeflag
);
1615 sprintf (buf
, " . #%d#", i
+ 1);
1616 strout (buf
, -1, -1, printcharfun
, 0);
1626 if (print_length
&& i
> print_length
)
1628 strout ("...", 3, 3, printcharfun
, 0);
1632 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1636 halftail
= XCDR (halftail
);
1640 /* OBJ non-nil here means it's the end of a dotted list. */
1643 strout (" . ", 3, 3, printcharfun
, 0);
1644 print_object (obj
, printcharfun
, escapeflag
);
1652 case Lisp_Vectorlike
:
1657 strout ("#<process ", -1, -1, printcharfun
, 0);
1658 print_string (XPROCESS (obj
)->name
, printcharfun
);
1662 print_string (XPROCESS (obj
)->name
, printcharfun
);
1664 else if (BOOL_VECTOR_P (obj
))
1667 register unsigned char c
;
1668 struct gcpro gcpro1
;
1670 = (XBOOL_VECTOR (obj
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1676 sprintf (buf
, "%d", XBOOL_VECTOR (obj
)->size
);
1677 strout (buf
, -1, -1, printcharfun
, 0);
1680 /* Don't print more characters than the specified maximum.
1681 Negative values of print-length are invalid. Treat them
1682 like a print-length of nil. */
1683 if (NATNUMP (Vprint_length
)
1684 && XFASTINT (Vprint_length
) < size_in_chars
)
1685 size_in_chars
= XFASTINT (Vprint_length
);
1687 for (i
= 0; i
< size_in_chars
; i
++)
1690 c
= XBOOL_VECTOR (obj
)->data
[i
];
1691 if (c
== '\n' && print_escape_newlines
)
1696 else if (c
== '\f' && print_escape_newlines
)
1703 if (c
== '\"' || c
== '\\')
1712 else if (SUBRP (obj
))
1714 strout ("#<subr ", -1, -1, printcharfun
, 0);
1715 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
, 0);
1718 else if (WINDOWP (obj
))
1720 strout ("#<window ", -1, -1, printcharfun
, 0);
1721 sprintf (buf
, "%d", XFASTINT (XWINDOW (obj
)->sequence_number
));
1722 strout (buf
, -1, -1, printcharfun
, 0);
1723 if (!NILP (XWINDOW (obj
)->buffer
))
1725 strout (" on ", -1, -1, printcharfun
, 0);
1726 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1730 else if (HASH_TABLE_P (obj
))
1732 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1733 strout ("#<hash-table", -1, -1, printcharfun
, 0);
1734 if (SYMBOLP (h
->test
))
1738 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
, 0);
1740 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
, 0);
1742 sprintf (buf
, "%d/%d", XFASTINT (h
->count
),
1743 XVECTOR (h
->next
)->size
);
1744 strout (buf
, -1, -1, printcharfun
, 0);
1746 sprintf (buf
, " 0x%lx", (unsigned long) h
);
1747 strout (buf
, -1, -1, printcharfun
, 0);
1750 else if (BUFFERP (obj
))
1752 if (NILP (XBUFFER (obj
)->name
))
1753 strout ("#<killed buffer>", -1, -1, printcharfun
, 0);
1754 else if (escapeflag
)
1756 strout ("#<buffer ", -1, -1, printcharfun
, 0);
1757 print_string (XBUFFER (obj
)->name
, printcharfun
);
1761 print_string (XBUFFER (obj
)->name
, printcharfun
);
1763 else if (WINDOW_CONFIGURATIONP (obj
))
1765 strout ("#<window-configuration>", -1, -1, printcharfun
, 0);
1767 else if (FRAMEP (obj
))
1769 strout ((FRAME_LIVE_P (XFRAME (obj
))
1770 ? "#<frame " : "#<dead frame "),
1771 -1, -1, printcharfun
, 0);
1772 print_string (XFRAME (obj
)->name
, printcharfun
);
1773 sprintf (buf
, " 0x%lx", (unsigned long) (XFRAME (obj
)));
1774 strout (buf
, -1, -1, printcharfun
, 0);
1779 int size
= XVECTOR (obj
)->size
;
1780 if (COMPILEDP (obj
))
1783 size
&= PSEUDOVECTOR_SIZE_MASK
;
1785 if (CHAR_TABLE_P (obj
))
1787 /* We print a char-table as if it were a vector,
1788 lumping the parent and default slots in with the
1789 character slots. But we add #^ as a prefix. */
1792 if (SUB_CHAR_TABLE_P (obj
))
1794 size
&= PSEUDOVECTOR_SIZE_MASK
;
1796 if (size
& PSEUDOVECTOR_FLAG
)
1802 register Lisp_Object tem
;
1803 int real_size
= size
;
1805 /* Don't print more elements than the specified maximum. */
1806 if (NATNUMP (Vprint_length
)
1807 && XFASTINT (Vprint_length
) < size
)
1808 size
= XFASTINT (Vprint_length
);
1810 for (i
= 0; i
< size
; i
++)
1812 if (i
) PRINTCHAR (' ');
1813 tem
= XVECTOR (obj
)->contents
[i
];
1814 print_object (tem
, printcharfun
, escapeflag
);
1816 if (size
< real_size
)
1817 strout (" ...", 4, 4, printcharfun
, 0);
1824 switch (XMISCTYPE (obj
))
1826 case Lisp_Misc_Marker
:
1827 strout ("#<marker ", -1, -1, printcharfun
, 0);
1828 /* Do you think this is necessary? */
1829 if (XMARKER (obj
)->insertion_type
!= 0)
1830 strout ("(moves after insertion) ", -1, -1, printcharfun
, 0);
1831 if (!(XMARKER (obj
)->buffer
))
1832 strout ("in no buffer", -1, -1, printcharfun
, 0);
1835 sprintf (buf
, "at %d", marker_position (obj
));
1836 strout (buf
, -1, -1, printcharfun
, 0);
1837 strout (" in ", -1, -1, printcharfun
, 0);
1838 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
1843 case Lisp_Misc_Overlay
:
1844 strout ("#<overlay ", -1, -1, printcharfun
, 0);
1845 if (!(XMARKER (OVERLAY_START (obj
))->buffer
))
1846 strout ("in no buffer", -1, -1, printcharfun
, 0);
1849 sprintf (buf
, "from %d to %d in ",
1850 marker_position (OVERLAY_START (obj
)),
1851 marker_position (OVERLAY_END (obj
)));
1852 strout (buf
, -1, -1, printcharfun
, 0);
1853 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
1859 /* Remaining cases shouldn't happen in normal usage, but let's print
1860 them anyway for the benefit of the debugger. */
1861 case Lisp_Misc_Free
:
1862 strout ("#<misc free cell>", -1, -1, printcharfun
, 0);
1865 case Lisp_Misc_Intfwd
:
1866 sprintf (buf
, "#<intfwd to %d>", *XINTFWD (obj
)->intvar
);
1867 strout (buf
, -1, -1, printcharfun
, 0);
1870 case Lisp_Misc_Boolfwd
:
1871 sprintf (buf
, "#<boolfwd to %s>",
1872 (*XBOOLFWD (obj
)->boolvar
? "t" : "nil"));
1873 strout (buf
, -1, -1, printcharfun
, 0);
1876 case Lisp_Misc_Objfwd
:
1877 strout ("#<objfwd to ", -1, -1, printcharfun
, 0);
1878 print_object (*XOBJFWD (obj
)->objvar
, printcharfun
, escapeflag
);
1882 case Lisp_Misc_Buffer_Objfwd
:
1883 strout ("#<buffer_objfwd to ", -1, -1, printcharfun
, 0);
1884 print_object (PER_BUFFER_VALUE (current_buffer
,
1885 XBUFFER_OBJFWD (obj
)->offset
),
1886 printcharfun
, escapeflag
);
1890 case Lisp_Misc_Kboard_Objfwd
:
1891 strout ("#<kboard_objfwd to ", -1, -1, printcharfun
, 0);
1892 print_object (*(Lisp_Object
*)((char *) current_kboard
1893 + XKBOARD_OBJFWD (obj
)->offset
),
1894 printcharfun
, escapeflag
);
1898 case Lisp_Misc_Buffer_Local_Value
:
1899 strout ("#<buffer_local_value ", -1, -1, printcharfun
, 0);
1900 goto do_buffer_local
;
1901 case Lisp_Misc_Some_Buffer_Local_Value
:
1902 strout ("#<some_buffer_local_value ", -1, -1, printcharfun
, 0);
1904 strout ("[realvalue] ", -1, -1, printcharfun
, 0);
1905 print_object (XBUFFER_LOCAL_VALUE (obj
)->realvalue
,
1906 printcharfun
, escapeflag
);
1907 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_buffer
)
1908 strout ("[local in buffer] ", -1, -1, printcharfun
, 0);
1910 strout ("[buffer] ", -1, -1, printcharfun
, 0);
1911 print_object (XBUFFER_LOCAL_VALUE (obj
)->buffer
,
1912 printcharfun
, escapeflag
);
1913 if (XBUFFER_LOCAL_VALUE (obj
)->check_frame
)
1915 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_frame
)
1916 strout ("[local in frame] ", -1, -1, printcharfun
, 0);
1918 strout ("[frame] ", -1, -1, printcharfun
, 0);
1919 print_object (XBUFFER_LOCAL_VALUE (obj
)->frame
,
1920 printcharfun
, escapeflag
);
1922 strout ("[alist-elt] ", -1, -1, printcharfun
, 0);
1923 print_object (XCAR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
1924 printcharfun
, escapeflag
);
1925 strout ("[default-value] ", -1, -1, printcharfun
, 0);
1926 print_object (XCDR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
1927 printcharfun
, escapeflag
);
1939 /* We're in trouble if this happens!
1940 Probably should just abort () */
1941 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
, 0);
1943 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
1944 else if (VECTORLIKEP (obj
))
1945 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
1947 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
1948 strout (buf
, -1, -1, printcharfun
, 0);
1949 strout (" Save your buffers immediately and please report this bug>",
1950 -1, -1, printcharfun
, 0);
1958 /* Print a description of INTERVAL using PRINTCHARFUN.
1959 This is part of printing a string that has text properties. */
1962 print_interval (interval
, printcharfun
)
1964 Lisp_Object printcharfun
;
1967 print_object (make_number (interval
->position
), printcharfun
, 1);
1969 print_object (make_number (interval
->position
+ LENGTH (interval
)),
1972 print_object (interval
->plist
, printcharfun
, 1);
1979 Qtemp_buffer_setup_hook
= intern ("temp-buffer-setup-hook");
1980 staticpro (&Qtemp_buffer_setup_hook
);
1982 DEFVAR_LISP ("standard-output", &Vstandard_output
,
1983 doc
: /* Output stream `print' uses by default for outputting a character.
1984 This may be any function of one argument.
1985 It may also be a buffer (output is inserted before point)
1986 or a marker (output is inserted and the marker is advanced)
1987 or the symbol t (output appears in the echo area). */);
1988 Vstandard_output
= Qt
;
1989 Qstandard_output
= intern ("standard-output");
1990 staticpro (&Qstandard_output
);
1992 DEFVAR_LISP ("float-output-format", &Vfloat_output_format
,
1993 doc
: /* The format descriptor string used to print floats.
1994 This is a %-spec like those accepted by `printf' in C,
1995 but with some restrictions. It must start with the two characters `%.'.
1996 After that comes an integer precision specification,
1997 and then a letter which controls the format.
1998 The letters allowed are `e', `f' and `g'.
1999 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2000 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2001 Use `g' to choose the shorter of those two formats for the number at hand.
2002 The precision in any of these cases is the number of digits following
2003 the decimal point. With `f', a precision of 0 means to omit the
2004 decimal point. 0 is not allowed with `e' or `g'.
2006 A value of nil means to use the shortest notation
2007 that represents the number without losing information. */);
2008 Vfloat_output_format
= Qnil
;
2009 Qfloat_output_format
= intern ("float-output-format");
2010 staticpro (&Qfloat_output_format
);
2012 DEFVAR_LISP ("print-length", &Vprint_length
,
2013 doc
: /* Maximum length of list to print before abbreviating.
2014 A value of nil means no limit. See also `eval-expression-print-length'. */);
2015 Vprint_length
= Qnil
;
2017 DEFVAR_LISP ("print-level", &Vprint_level
,
2018 doc
: /* Maximum depth of list nesting to print before abbreviating.
2019 A value of nil means no limit. See also `eval-expression-print-level'. */);
2020 Vprint_level
= Qnil
;
2022 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines
,
2023 doc
: /* Non-nil means print newlines in strings as `\\n'.
2024 Also print formfeeds as `\\f'. */);
2025 print_escape_newlines
= 0;
2027 DEFVAR_BOOL ("print-escape-nonascii", &print_escape_nonascii
,
2028 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2029 \(OOO is the octal representation of the character code.)
2030 Only single-byte characters are affected, and only in `prin1'. */);
2031 print_escape_nonascii
= 0;
2033 DEFVAR_BOOL ("print-escape-multibyte", &print_escape_multibyte
,
2034 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2035 \(XXXX is the hex representation of the character code.)
2036 This affects only `prin1'. */);
2037 print_escape_multibyte
= 0;
2039 DEFVAR_BOOL ("print-quoted", &print_quoted
,
2040 doc
: /* Non-nil means print quoted forms with reader syntax.
2041 I.e., (quote foo) prints as 'foo, (function foo) as #'foo, and backquoted
2042 forms print as in the new syntax. */);
2045 DEFVAR_LISP ("print-gensym", &Vprint_gensym
,
2046 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2047 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2048 When the uninterned symbol appears within a recursive data structure,
2049 and the symbol appears more than once, in addition use the #N# and #N=
2050 constructs as needed, so that multiple references to the same symbol are
2051 shared once again when the text is read back. */);
2052 Vprint_gensym
= Qnil
;
2054 DEFVAR_LISP ("print-circle", &Vprint_circle
,
2055 doc
: /* *Non-nil means print recursive structures using #N= and #N# syntax.
2056 If nil, printing proceeds recursively and may lead to
2057 `max-lisp-eval-depth' being exceeded or an error may occur:
2058 \"Apparently circular structure being printed.\" Also see
2059 `print-length' and `print-level'.
2060 If non-nil, shared substructures anywhere in the structure are printed
2061 with `#N=' before the first occurrence (in the order of the print
2062 representation) and `#N#' in place of each subsequent occurrence,
2063 where N is a positive decimal integer. */);
2064 Vprint_circle
= Qnil
;
2066 DEFVAR_LISP ("print-continuous-numbering", &Vprint_continuous_numbering
,
2067 doc
: /* *Non-nil means number continuously across print calls.
2068 This affects the numbers printed for #N= labels and #M# references.
2069 See also `print-circle', `print-gensym', and `print-number-table'.
2070 This variable should not be set with `setq'; bind it with a `let' instead. */);
2071 Vprint_continuous_numbering
= Qnil
;
2073 DEFVAR_LISP ("print-number-table", &Vprint_number_table
,
2074 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2075 The Lisp printer uses this vector to detect Lisp objects referenced more
2076 than once. When `print-continuous-numbering' is bound to t, you should
2077 probably also bind `print-number-table' to nil. This ensures that the
2078 value of `print-number-table' can be garbage-collected once the printing
2080 Vprint_number_table
= Qnil
;
2082 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2083 staticpro (&Vprin1_to_string_buffer
);
2086 defsubr (&Sprin1_to_string
);
2087 defsubr (&Serror_message_string
);
2091 defsubr (&Swrite_char
);
2092 defsubr (&Sexternal_debugging_output
);
2094 Qexternal_debugging_output
= intern ("external-debugging-output");
2095 staticpro (&Qexternal_debugging_output
);
2097 Qprint_escape_newlines
= intern ("print-escape-newlines");
2098 staticpro (&Qprint_escape_newlines
);
2100 Qprint_escape_multibyte
= intern ("print-escape-multibyte");
2101 staticpro (&Qprint_escape_multibyte
);
2103 Qprint_escape_nonascii
= intern ("print-escape-nonascii");
2104 staticpro (&Qprint_escape_nonascii
);
2106 defsubr (&Swith_output_to_temp_buffer
);