1 /* Lisp object printing and output streams.
2 Copyright (C) 1985, 86, 88, 93, 94, 95, 97 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
32 #include "dispextern.h"
35 #endif /* not standalone */
37 #ifdef USE_TEXT_PROPERTIES
38 #include "intervals.h"
41 Lisp_Object Vstandard_output
, Qstandard_output
;
43 /* These are used to print like we read. */
44 extern Lisp_Object Qbackquote
, Qcomma
, Qcomma_at
, Qcomma_dot
, Qfunction
;
46 #ifdef LISP_FLOAT_TYPE
47 Lisp_Object Vfloat_output_format
, Qfloat_output_format
;
49 /* Work around a problem that happens because math.h on hpux 7
50 defines two static variables--which, in Emacs, are not really static,
51 because `static' is defined as nothing. The problem is that they are
52 defined both here and in lread.c.
53 These macros prevent the name conflict. */
54 #if defined (HPUX) && !defined (HPUX8)
55 #define _MAXLDBL print_maxldbl
56 #define _NMAXLDBL print_nmaxldbl
66 /* Default to values appropriate for IEEE floating point. */
71 #define DBL_MANT_DIG 53
77 #define DBL_MIN 2.2250738585072014e-308
80 #ifdef DBL_MIN_REPLACEMENT
82 #define DBL_MIN DBL_MIN_REPLACEMENT
85 /* Define DOUBLE_DIGITS_BOUND, an upper bound on the number of decimal digits
86 needed to express a float without losing information.
87 The general-case formula is valid for the usual case, IEEE floating point,
88 but many compilers can't optimize the formula to an integer constant,
89 so make a special case for it. */
90 #if FLT_RADIX == 2 && DBL_MANT_DIG == 53
91 #define DOUBLE_DIGITS_BOUND 17 /* IEEE floating point */
93 #define DOUBLE_DIGITS_BOUND ((int) ceil (log10 (pow (FLT_RADIX, DBL_MANT_DIG))))
96 #endif /* LISP_FLOAT_TYPE */
98 /* Avoid actual stack overflow in print. */
101 /* Detect most circularities to print finite output. */
102 #define PRINT_CIRCLE 200
103 Lisp_Object being_printed
[PRINT_CIRCLE
];
105 /* When printing into a buffer, first we put the text in this
106 block, then insert it all at once. */
109 /* Size allocated in print_buffer. */
110 int print_buffer_size
;
111 /* Size used in print_buffer. */
112 int print_buffer_pos
;
114 /* Maximum length of list to print in full; noninteger means
115 effectively infinity */
117 Lisp_Object Vprint_length
;
119 /* Maximum depth of list to print in full; noninteger means
120 effectively infinity. */
122 Lisp_Object Vprint_level
;
124 /* Nonzero means print newlines in strings as \n. */
126 int print_escape_newlines
;
128 Lisp_Object Qprint_escape_newlines
;
130 /* Nonzero means print (quote foo) forms as 'foo, etc. */
134 /* Non-nil means print #: before uninterned symbols.
135 Neither t nor nil means so that and don't clear Vprint_gensym_alist
136 on entry to and exit from print functions. */
138 Lisp_Object Vprint_gensym
;
140 /* Association list of certain objects that are `eq' in the form being
141 printed and which should be `eq' when read back in, using the #n=object
142 and #n# reader forms. Each element has the form (object . n). */
144 Lisp_Object Vprint_gensym_alist
;
146 /* Nonzero means print newline to stdout before next minibuffer message.
147 Defined in xdisp.c */
149 extern int noninteractive_need_newline
;
151 extern int minibuffer_auto_raise
;
153 #ifdef MAX_PRINT_CHARS
154 static int print_chars
;
155 static int max_print
;
156 #endif /* MAX_PRINT_CHARS */
158 void print_interval ();
161 /* Convert between chars and GLYPHs */
165 register GLYPH
*glyphs
;
175 str_to_glyph_cpy (str
, glyphs
)
179 register GLYPH
*gp
= glyphs
;
180 register char *cp
= str
;
187 str_to_glyph_ncpy (str
, glyphs
, n
)
192 register GLYPH
*gp
= glyphs
;
193 register char *cp
= str
;
200 glyph_to_str_cpy (glyphs
, str
)
204 register GLYPH
*gp
= glyphs
;
205 register char *cp
= str
;
208 *str
++ = *gp
++ & 0377;
212 /* Low level output routines for characters and strings */
214 /* Lisp functions to do output using a stream
215 must have the stream in a variable called printcharfun
216 and must start with PRINTPREPARE, end with PRINTFINISH,
217 and use PRINTDECLARE to declare common variables.
218 Use PRINTCHAR to output one character,
219 or call strout to output a block of characters.
222 #define PRINTDECLARE \
223 struct buffer *old = current_buffer; \
224 int old_point = -1, start_point; \
225 int old_point_byte, start_point_byte; \
226 int specpdl_count = specpdl_ptr - specpdl; \
227 int free_print_buffer = 0; \
230 #define PRINTPREPARE \
231 original = printcharfun; \
232 if (NILP (printcharfun)) printcharfun = Qt; \
233 if (BUFFERP (printcharfun)) \
235 if (XBUFFER (printcharfun) != current_buffer) \
236 Fset_buffer (printcharfun); \
237 printcharfun = Qnil; \
239 if (MARKERP (printcharfun)) \
241 if (!(XMARKER (original)->buffer)) \
242 error ("Marker does not point anywhere"); \
243 if (XMARKER (original)->buffer != current_buffer) \
244 set_buffer_internal (XMARKER (original)->buffer); \
246 old_point_byte = PT_BYTE; \
247 SET_PT_BOTH (marker_position (printcharfun), \
248 marker_byte_position (printcharfun)); \
250 start_point_byte = PT_BYTE; \
251 printcharfun = Qnil; \
253 if (NILP (printcharfun)) \
255 if (print_buffer != 0) \
256 record_unwind_protect (print_unwind, \
257 make_string (print_buffer, \
258 print_buffer_pos)); \
261 print_buffer_size = 1000; \
262 print_buffer = (char *) xmalloc (print_buffer_size); \
263 free_print_buffer = 1; \
265 print_buffer_pos = 0; \
267 if (!CONSP (Vprint_gensym)) \
268 Vprint_gensym_alist = Qnil
270 #define PRINTFINISH \
271 if (NILP (printcharfun)) \
272 insert (print_buffer, print_buffer_pos); \
273 if (free_print_buffer) \
275 xfree (print_buffer); \
278 unbind_to (specpdl_count, Qnil); \
279 if (MARKERP (original)) \
280 set_marker_both (original, Qnil, PT, PT_BYTE); \
281 if (old_point >= 0) \
282 SET_PT_BOTH (old_point + (old_point >= start_point \
283 ? PT - start_point : 0), \
284 old_point_byte + (old_point_byte >= start_point_byte \
285 ? PT_BYTE - start_point_byte : 0)); \
286 if (old != current_buffer) \
287 set_buffer_internal (old); \
288 if (!CONSP (Vprint_gensym)) \
289 Vprint_gensym_alist = Qnil
291 #define PRINTCHAR(ch) printchar (ch, printcharfun)
293 /* Nonzero if there is no room to print any more characters
294 so print might as well return right away. */
296 #define PRINTFULLP() \
297 (EQ (printcharfun, Qt) && !noninteractive \
298 && printbufidx >= FRAME_WIDTH (XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window)))))
300 /* This is used to restore the saved contents of print_buffer
301 when there is a recursive call to print. */
303 print_unwind (saved_text
)
304 Lisp_Object saved_text
;
306 bcopy (XSTRING (saved_text
)->data
, print_buffer
, XSTRING (saved_text
)->size
);
309 /* Index of first unused element of FRAME_MESSAGE_BUF (mini_frame). */
310 static int printbufidx
;
319 #ifdef MAX_PRINT_CHARS
322 #endif /* MAX_PRINT_CHARS */
327 unsigned char work
[4], *str
;
330 len
= CHAR_STRING (ch
, work
, str
);
331 if (print_buffer_pos
+ len
>= print_buffer_size
)
332 print_buffer
= (char *) xrealloc (print_buffer
,
333 print_buffer_size
*= 2);
334 bcopy (str
, print_buffer
+ print_buffer_pos
, len
);
335 print_buffer_pos
+= len
;
342 = XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window
)));
343 unsigned char work
[4], *str
;
344 int len
= CHAR_STRING (ch
, work
, str
);
351 putchar (*str
), str
++;
352 noninteractive_need_newline
= 1;
356 if (echo_area_glyphs
!= FRAME_MESSAGE_BUF (mini_frame
)
357 || !message_buf_print
)
359 message_log_maybe_newline ();
360 echo_area_glyphs
= FRAME_MESSAGE_BUF (mini_frame
);
362 echo_area_glyphs_length
= 0;
363 message_buf_print
= 1;
365 if (minibuffer_auto_raise
)
367 Lisp_Object mini_window
;
369 /* Get the frame containing the minibuffer
370 that the selected frame is using. */
371 mini_window
= FRAME_MINIBUF_WINDOW (selected_frame
);
373 Fraise_frame (WINDOW_FRAME (XWINDOW (mini_window
)));
377 message_dolog (str
, len
, 0);
378 if (printbufidx
< FRAME_MESSAGE_BUF_SIZE (mini_frame
) - len
)
379 bcopy (str
, &FRAME_MESSAGE_BUF (mini_frame
)[printbufidx
], len
),
381 FRAME_MESSAGE_BUF (mini_frame
)[printbufidx
] = 0;
382 echo_area_glyphs_length
= printbufidx
;
386 #endif /* not standalone */
388 XSETFASTINT (ch1
, ch
);
393 strout (ptr
, size
, printcharfun
)
396 Lisp_Object printcharfun
;
403 if (EQ (printcharfun
, Qnil
))
405 if (print_buffer_pos
+ size
> print_buffer_size
)
407 print_buffer_size
= print_buffer_size
* 2 + size
;
408 print_buffer
= (char *) xrealloc (print_buffer
,
411 bcopy (ptr
, print_buffer
+ print_buffer_pos
, size
);
412 print_buffer_pos
+= size
;
414 #ifdef MAX_PRINT_CHARS
417 #endif /* MAX_PRINT_CHARS */
420 if (EQ (printcharfun
, Qt
))
423 = XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window
)));
427 #ifdef MAX_PRINT_CHARS
430 #endif /* MAX_PRINT_CHARS */
434 fwrite (ptr
, 1, size
, stdout
);
435 noninteractive_need_newline
= 1;
439 if (echo_area_glyphs
!= FRAME_MESSAGE_BUF (mini_frame
)
440 || !message_buf_print
)
442 message_log_maybe_newline ();
443 echo_area_glyphs
= FRAME_MESSAGE_BUF (mini_frame
);
445 echo_area_glyphs_length
= 0;
446 message_buf_print
= 1;
448 if (minibuffer_auto_raise
)
450 Lisp_Object mini_window
;
452 /* Get the frame containing the minibuffer
453 that the selected frame is using. */
454 mini_window
= FRAME_MINIBUF_WINDOW (selected_frame
);
456 Fraise_frame (WINDOW_FRAME (XWINDOW (mini_window
)));
460 message_dolog (ptr
, size
, 0);
461 if (size
> FRAME_MESSAGE_BUF_SIZE (mini_frame
) - printbufidx
- 1)
463 size
= FRAME_MESSAGE_BUF_SIZE (mini_frame
) - printbufidx
- 1;
464 /* Rewind incomplete multi-byte form. */
465 while (size
&& (unsigned char) ptr
[size
] >= 0xA0) size
--;
467 bcopy (ptr
, &FRAME_MESSAGE_BUF (mini_frame
) [printbufidx
], size
);
469 echo_area_glyphs_length
= printbufidx
;
470 FRAME_MESSAGE_BUF (mini_frame
) [printbufidx
] = 0;
478 /* Here, we must convert each multi-byte form to the
479 corresponding character code before handing it to PRINTCHAR. */
481 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size
- i
, len
);
488 /* Print the contents of a string STRING using PRINTCHARFUN.
489 It isn't safe to use strout in many cases,
490 because printing one char can relocate. */
493 print_string (string
, printcharfun
)
495 Lisp_Object printcharfun
;
497 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
498 /* strout is safe for output to a frame (echo area) or to print_buffer. */
499 strout (XSTRING (string
)->data
, XSTRING (string
)->size
, printcharfun
);
502 /* Otherwise, fetch the string address for each character. */
504 int size
= XSTRING (string
)->size
;
507 for (i
= 0; i
< size
; i
++)
508 PRINTCHAR (XSTRING (string
)->data
[i
]);
513 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
514 "Output character CHARACTER to stream PRINTCHARFUN.\n\
515 PRINTCHARFUN defaults to the value of `standard-output' (which see).")
516 (character
, printcharfun
)
517 Lisp_Object character
, printcharfun
;
521 if (NILP (printcharfun
))
522 printcharfun
= Vstandard_output
;
523 CHECK_NUMBER (character
, 0);
525 PRINTCHAR (XINT (character
));
530 /* Used from outside of print.c to print a block of SIZE chars at DATA
531 on the default output stream.
532 Do not use this on the contents of a Lisp string. */
535 write_string (data
, size
)
540 Lisp_Object printcharfun
;
542 printcharfun
= Vstandard_output
;
545 strout (data
, size
, printcharfun
);
549 /* Used from outside of print.c to print a block of SIZE chars at DATA
550 on a specified stream PRINTCHARFUN.
551 Do not use this on the contents of a Lisp string. */
554 write_string_1 (data
, size
, printcharfun
)
557 Lisp_Object printcharfun
;
562 strout (data
, size
, printcharfun
);
570 temp_output_buffer_setup (bufname
)
573 register struct buffer
*old
= current_buffer
;
574 register Lisp_Object buf
;
576 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
578 current_buffer
->directory
= old
->directory
;
579 current_buffer
->read_only
= Qnil
;
582 XSETBUFFER (buf
, current_buffer
);
583 specbind (Qstandard_output
, buf
);
585 set_buffer_internal (old
);
589 internal_with_output_to_temp_buffer (bufname
, function
, args
)
591 Lisp_Object (*function
) ();
594 int count
= specpdl_ptr
- specpdl
;
595 Lisp_Object buf
, val
;
599 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
600 temp_output_buffer_setup (bufname
);
601 buf
= Vstandard_output
;
604 val
= (*function
) (args
);
607 temp_output_buffer_show (buf
);
610 return unbind_to (count
, val
);
613 DEFUN ("with-output-to-temp-buffer", Fwith_output_to_temp_buffer
, Swith_output_to_temp_buffer
,
615 "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.\n\
616 The buffer is cleared out initially, and marked as unmodified when done.\n\
617 All output done by BODY is inserted in that buffer by default.\n\
618 The buffer is displayed in another window, but not selected.\n\
619 The value of the last form in BODY is returned.\n\
620 If BODY does not finish normally, the buffer BUFNAME is not displayed.\n\n\
621 If variable `temp-buffer-show-function' is non-nil, call it at the end\n\
622 to get the buffer displayed. It gets one argument, the buffer to display.")
628 int count
= specpdl_ptr
- specpdl
;
629 Lisp_Object buf
, val
;
632 name
= Feval (Fcar (args
));
635 CHECK_STRING (name
, 0);
636 temp_output_buffer_setup (XSTRING (name
)->data
);
637 buf
= Vstandard_output
;
639 val
= Fprogn (Fcdr (args
));
641 temp_output_buffer_show (buf
);
643 return unbind_to (count
, val
);
645 #endif /* not standalone */
647 static void print ();
649 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
650 "Output a newline to stream PRINTCHARFUN.\n\
651 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used.")
653 Lisp_Object printcharfun
;
657 if (NILP (printcharfun
))
658 printcharfun
= Vstandard_output
;
665 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
666 "Output the printed representation of OBJECT, any Lisp object.\n\
667 Quoting characters are printed when needed to make output that `read'\n\
668 can handle, whenever this is possible.\n\
669 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
670 (object
, printcharfun
)
671 Lisp_Object object
, printcharfun
;
675 #ifdef MAX_PRINT_CHARS
677 #endif /* MAX_PRINT_CHARS */
678 if (NILP (printcharfun
))
679 printcharfun
= Vstandard_output
;
682 print (object
, printcharfun
, 1);
687 /* a buffer which is used to hold output being built by prin1-to-string */
688 Lisp_Object Vprin1_to_string_buffer
;
690 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
691 "Return a string containing the printed representation of OBJECT,\n\
692 any Lisp object. Quoting characters are used when needed to make output\n\
693 that `read' can handle, whenever this is possible, unless the optional\n\
694 second argument NOESCAPE is non-nil.")
696 Lisp_Object object
, noescape
;
699 Lisp_Object printcharfun
;
700 struct gcpro gcpro1
, gcpro2
;
703 /* Save and restore this--we are altering a buffer
704 but we don't want to deactivate the mark just for that.
705 No need for specbind, since errors deactivate the mark. */
706 tem
= Vdeactivate_mark
;
707 GCPRO2 (object
, tem
);
709 printcharfun
= Vprin1_to_string_buffer
;
712 print (object
, printcharfun
, NILP (noescape
));
713 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
715 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
716 object
= Fbuffer_string ();
719 set_buffer_internal (old
);
721 Vdeactivate_mark
= tem
;
727 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
728 "Output the printed representation of OBJECT, any Lisp object.\n\
729 No quoting characters are used; no delimiters are printed around\n\
730 the contents of strings.\n\
731 Output stream is PRINTCHARFUN, or value of standard-output (which see).")
732 (object
, printcharfun
)
733 Lisp_Object object
, printcharfun
;
737 if (NILP (printcharfun
))
738 printcharfun
= Vstandard_output
;
741 print (object
, printcharfun
, 0);
746 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
747 "Output the printed representation of OBJECT, with newlines around it.\n\
748 Quoting characters are printed when needed to make output that `read'\n\
749 can handle, whenever this is possible.\n\
750 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
751 (object
, printcharfun
)
752 Lisp_Object object
, printcharfun
;
757 #ifdef MAX_PRINT_CHARS
759 max_print
= MAX_PRINT_CHARS
;
760 #endif /* MAX_PRINT_CHARS */
761 if (NILP (printcharfun
))
762 printcharfun
= Vstandard_output
;
767 print (object
, printcharfun
, 1);
770 #ifdef MAX_PRINT_CHARS
773 #endif /* MAX_PRINT_CHARS */
778 /* The subroutine object for external-debugging-output is kept here
779 for the convenience of the debugger. */
780 Lisp_Object Qexternal_debugging_output
;
782 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
783 "Write CHARACTER to stderr.\n\
784 You can call print while debugging emacs, and pass it this function\n\
785 to make it write to the debugging output.\n")
787 Lisp_Object character
;
789 CHECK_NUMBER (character
, 0);
790 putc (XINT (character
), stderr
);
793 /* Send the output to a debugger (nothing happens if there isn't one). */
795 char buf
[2] = {(char) XINT (character
), '\0'};
796 OutputDebugString (buf
);
803 /* This is the interface for debugging printing. */
809 Fprin1 (arg
, Qexternal_debugging_output
);
810 fprintf (stderr
, "\r\n");
813 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
815 "Convert an error value (ERROR-SYMBOL . DATA) to an error message.")
819 struct buffer
*old
= current_buffer
;
820 Lisp_Object original
, printcharfun
, value
;
823 /* If OBJ is (error STRING), just return STRING.
824 That is not only faster, it also avoids the need to allocate
825 space here when the error is due to memory full. */
826 if (CONSP (obj
) && EQ (XCONS (obj
)->car
, Qerror
)
827 && CONSP (XCONS (obj
)->cdr
)
828 && STRINGP (XCONS (XCONS (obj
)->cdr
)->car
)
829 && NILP (XCONS (XCONS (obj
)->cdr
)->cdr
))
830 return XCONS (XCONS (obj
)->cdr
)->car
;
832 print_error_message (obj
, Vprin1_to_string_buffer
);
834 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
835 value
= Fbuffer_string ();
839 set_buffer_internal (old
);
845 /* Print an error message for the error DATA
846 onto Lisp output stream STREAM (suitable for the print functions). */
849 print_error_message (data
, stream
)
850 Lisp_Object data
, stream
;
852 Lisp_Object errname
, errmsg
, file_error
, tail
;
856 errname
= Fcar (data
);
858 if (EQ (errname
, Qerror
))
861 if (!CONSP (data
)) data
= Qnil
;
862 errmsg
= Fcar (data
);
867 errmsg
= Fget (errname
, Qerror_message
);
868 file_error
= Fmemq (Qfile_error
,
869 Fget (errname
, Qerror_conditions
));
872 /* Print an error message including the data items. */
874 tail
= Fcdr_safe (data
);
877 /* For file-error, make error message by concatenating
878 all the data items. They are all strings. */
879 if (!NILP (file_error
) && !NILP (tail
))
880 errmsg
= XCONS (tail
)->car
, tail
= XCONS (tail
)->cdr
;
882 if (STRINGP (errmsg
))
883 Fprinc (errmsg
, stream
);
885 write_string_1 ("peculiar error", -1, stream
);
887 for (i
= 0; CONSP (tail
); tail
= Fcdr (tail
), i
++)
889 write_string_1 (i
? ", " : ": ", 2, stream
);
890 if (!NILP (file_error
))
891 Fprinc (Fcar (tail
), stream
);
893 Fprin1 (Fcar (tail
), stream
);
898 #ifdef LISP_FLOAT_TYPE
901 * The buffer should be at least as large as the max string size of the
902 * largest float, printed in the biggest notation. This is undoubtedly
903 * 20d float_output_format, with the negative of the C-constant "HUGE"
906 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
908 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
909 * case of -1e307 in 20d float_output_format. What is one to do (short of
910 * re-writing _doprnt to be more sane)?
915 float_to_string (buf
, data
)
922 if (NILP (Vfloat_output_format
)
923 || !STRINGP (Vfloat_output_format
))
926 /* Generate the fewest number of digits that represent the
927 floating point value without losing information.
928 The following method is simple but a bit slow.
929 For ideas about speeding things up, please see:
931 Guy L Steele Jr & Jon L White, How to print floating-point numbers
932 accurately. SIGPLAN notices 25, 6 (June 1990), 112-126.
934 Robert G Burger & R Kent Dybvig, Printing floating point numbers
935 quickly and accurately, SIGPLAN notices 31, 5 (May 1996), 108-116. */
937 width
= fabs (data
) < DBL_MIN
? 1 : DBL_DIG
;
939 sprintf (buf
, "%.*g", width
, data
);
940 while (width
++ < DOUBLE_DIGITS_BOUND
&& atof (buf
) != data
);
944 /* Check that the spec we have is fully valid.
945 This means not only valid for printf,
946 but meant for floats, and reasonable. */
947 cp
= XSTRING (Vfloat_output_format
)->data
;
956 /* Check the width specification. */
958 if ('0' <= *cp
&& *cp
<= '9')
962 width
= (width
* 10) + (*cp
++ - '0');
963 while (*cp
>= '0' && *cp
<= '9');
965 /* A precision of zero is valid only for %f. */
967 || (width
== 0 && *cp
!= 'f'))
971 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
977 sprintf (buf
, XSTRING (Vfloat_output_format
)->data
, data
);
980 /* Make sure there is a decimal point with digit after, or an
981 exponent, so that the value is readable as a float. But don't do
982 this with "%.0f"; it's valid for that not to produce a decimal
983 point. Note that width can be 0 only for %.0f. */
986 for (cp
= buf
; *cp
; cp
++)
987 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
990 if (*cp
== '.' && cp
[1] == 0)
1004 #endif /* LISP_FLOAT_TYPE */
1007 print (obj
, printcharfun
, escapeflag
)
1009 register Lisp_Object printcharfun
;
1016 #if 1 /* I'm not sure this is really worth doing. */
1017 /* Detect circularities and truncate them.
1018 No need to offer any alternative--this is better than an error. */
1019 if (CONSP (obj
) || VECTORP (obj
) || COMPILEDP (obj
))
1022 for (i
= 0; i
< print_depth
; i
++)
1023 if (EQ (obj
, being_printed
[i
]))
1025 sprintf (buf
, "#%d", i
);
1026 strout (buf
, -1, printcharfun
);
1032 being_printed
[print_depth
] = obj
;
1035 if (print_depth
> PRINT_CIRCLE
)
1036 error ("Apparently circular structure being printed");
1037 #ifdef MAX_PRINT_CHARS
1038 if (max_print
&& print_chars
> max_print
)
1043 #endif /* MAX_PRINT_CHARS */
1045 switch (XGCTYPE (obj
))
1048 if (sizeof (int) == sizeof (EMACS_INT
))
1049 sprintf (buf
, "%d", XINT (obj
));
1050 else if (sizeof (long) == sizeof (EMACS_INT
))
1051 sprintf (buf
, "%ld", XINT (obj
));
1054 strout (buf
, -1, printcharfun
);
1057 #ifdef LISP_FLOAT_TYPE
1060 char pigbuf
[350]; /* see comments in float_to_string */
1062 float_to_string (pigbuf
, XFLOAT(obj
)->data
);
1063 strout (pigbuf
, -1, printcharfun
);
1070 print_string (obj
, printcharfun
);
1074 register unsigned char c
;
1075 struct gcpro gcpro1
;
1080 #ifdef USE_TEXT_PROPERTIES
1081 if (!NULL_INTERVAL_P (XSTRING (obj
)->intervals
))
1089 size
= XSTRING (obj
)->size
;
1090 for (i
= 0; i
< size
;)
1092 /* Here, we must convert each multi-byte form to the
1093 corresponding character code before handing it to PRINTCHAR. */
1095 int c
= STRING_CHAR_AND_LENGTH (&XSTRING (obj
)->data
[i
],
1100 if (c
== '\n' && print_escape_newlines
)
1105 else if (c
== '\f' && print_escape_newlines
)
1112 if (c
== '\"' || c
== '\\')
1119 #ifdef USE_TEXT_PROPERTIES
1120 if (!NULL_INTERVAL_P (XSTRING (obj
)->intervals
))
1122 traverse_intervals (XSTRING (obj
)->intervals
,
1123 0, 0, print_interval
, printcharfun
);
1134 register int confusing
;
1135 register unsigned char *p
= XSYMBOL (obj
)->name
->data
;
1136 register unsigned char *end
= p
+ XSYMBOL (obj
)->name
->size
;
1137 register unsigned char c
;
1140 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1143 /* If symbol name begins with a digit, and ends with a digit,
1144 and contains nothing but digits and `e', it could be treated
1145 as a number. So set CONFUSING.
1147 Symbols that contain periods could also be taken as numbers,
1148 but periods are always escaped, so we don't have to worry
1150 else if (*p
>= '0' && *p
<= '9'
1151 && end
[-1] >= '0' && end
[-1] <= '9')
1153 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1154 /* Needed for \2e10. */
1157 confusing
= (end
== p
);
1162 /* If we print an uninterned symbol as part of a complex object and
1163 the flag print-gensym is non-nil, prefix it with #n= to read the
1164 object back with the #n# reader syntax later if needed. */
1165 if (! NILP (Vprint_gensym
) && NILP (XSYMBOL (obj
)->obarray
))
1167 if (print_depth
> 1)
1170 tem
= Fassq (obj
, Vprint_gensym_alist
);
1174 print (XCDR (tem
), printcharfun
, escapeflag
);
1180 if (CONSP (Vprint_gensym_alist
))
1181 XSETFASTINT (tem
, XFASTINT (XCDR (XCAR (Vprint_gensym_alist
))) + 1);
1183 XSETFASTINT (tem
, 1);
1184 Vprint_gensym_alist
= Fcons (Fcons (obj
, tem
), Vprint_gensym_alist
);
1187 print (tem
, printcharfun
, escapeflag
);
1195 size
= XSYMBOL (obj
)->name
->size
;
1196 for (i
= 0; i
< size
;)
1198 /* Here, we must convert each multi-byte form to the
1199 corresponding character code before handing it to PRINTCHAR. */
1201 int c
= STRING_CHAR_AND_LENGTH (&XSYMBOL (obj
)->name
->data
[i
],
1208 if (c
== '\"' || c
== '\\' || c
== '\''
1209 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1210 || c
== ',' || c
=='.' || c
== '`'
1211 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1213 PRINTCHAR ('\\'), confusing
= 0;
1221 /* If deeper than spec'd depth, print placeholder. */
1222 if (INTEGERP (Vprint_level
)
1223 && print_depth
> XINT (Vprint_level
))
1224 strout ("...", -1, printcharfun
);
1225 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1226 && (EQ (XCAR (obj
), Qquote
)))
1229 print (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1231 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1232 && (EQ (XCAR (obj
), Qfunction
)))
1236 print (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1238 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1239 && ((EQ (XCAR (obj
), Qbackquote
)
1240 || EQ (XCAR (obj
), Qcomma
)
1241 || EQ (XCAR (obj
), Qcomma_at
)
1242 || EQ (XCAR (obj
), Qcomma_dot
))))
1244 print (XCAR (obj
), printcharfun
, 0);
1245 print (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1252 register int max
= 0;
1254 if (INTEGERP (Vprint_length
))
1255 max
= XINT (Vprint_length
);
1256 /* Could recognize circularities in cdrs here,
1257 but that would make printing of long lists quadratic.
1258 It's not worth doing. */
1265 strout ("...", 3, printcharfun
);
1268 print (XCAR (obj
), printcharfun
, escapeflag
);
1274 strout (" . ", 3, printcharfun
);
1275 print (obj
, printcharfun
, escapeflag
);
1281 case Lisp_Vectorlike
:
1286 strout ("#<process ", -1, printcharfun
);
1287 print_string (XPROCESS (obj
)->name
, printcharfun
);
1291 print_string (XPROCESS (obj
)->name
, printcharfun
);
1293 else if (BOOL_VECTOR_P (obj
))
1296 register unsigned char c
;
1297 struct gcpro gcpro1
;
1299 = (XBOOL_VECTOR (obj
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1305 sprintf (buf
, "%d", XBOOL_VECTOR (obj
)->size
);
1306 strout (buf
, -1, printcharfun
);
1309 /* Don't print more characters than the specified maximum. */
1310 if (INTEGERP (Vprint_length
)
1311 && XINT (Vprint_length
) < size_in_chars
)
1312 size_in_chars
= XINT (Vprint_length
);
1314 for (i
= 0; i
< size_in_chars
; i
++)
1317 c
= XBOOL_VECTOR (obj
)->data
[i
];
1318 if (c
== '\n' && print_escape_newlines
)
1323 else if (c
== '\f' && print_escape_newlines
)
1330 if (c
== '\"' || c
== '\\')
1339 else if (SUBRP (obj
))
1341 strout ("#<subr ", -1, printcharfun
);
1342 strout (XSUBR (obj
)->symbol_name
, -1, printcharfun
);
1346 else if (WINDOWP (obj
))
1348 strout ("#<window ", -1, printcharfun
);
1349 sprintf (buf
, "%d", XFASTINT (XWINDOW (obj
)->sequence_number
));
1350 strout (buf
, -1, printcharfun
);
1351 if (!NILP (XWINDOW (obj
)->buffer
))
1353 strout (" on ", -1, printcharfun
);
1354 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1358 else if (BUFFERP (obj
))
1360 if (NILP (XBUFFER (obj
)->name
))
1361 strout ("#<killed buffer>", -1, printcharfun
);
1362 else if (escapeflag
)
1364 strout ("#<buffer ", -1, printcharfun
);
1365 print_string (XBUFFER (obj
)->name
, printcharfun
);
1369 print_string (XBUFFER (obj
)->name
, printcharfun
);
1371 else if (WINDOW_CONFIGURATIONP (obj
))
1373 strout ("#<window-configuration>", -1, printcharfun
);
1375 else if (FRAMEP (obj
))
1377 strout ((FRAME_LIVE_P (XFRAME (obj
))
1378 ? "#<frame " : "#<dead frame "),
1380 print_string (XFRAME (obj
)->name
, printcharfun
);
1381 sprintf (buf
, " 0x%lx", (unsigned long) (XFRAME (obj
)));
1382 strout (buf
, -1, printcharfun
);
1385 #endif /* not standalone */
1388 int size
= XVECTOR (obj
)->size
;
1389 if (COMPILEDP (obj
))
1392 size
&= PSEUDOVECTOR_SIZE_MASK
;
1394 if (CHAR_TABLE_P (obj
))
1396 /* We print a char-table as if it were a vector,
1397 lumping the parent and default slots in with the
1398 character slots. But we add #^ as a prefix. */
1401 if (SUB_CHAR_TABLE_P (obj
))
1403 size
&= PSEUDOVECTOR_SIZE_MASK
;
1405 if (size
& PSEUDOVECTOR_FLAG
)
1411 register Lisp_Object tem
;
1413 /* Don't print more elements than the specified maximum. */
1414 if (INTEGERP (Vprint_length
)
1415 && XINT (Vprint_length
) < size
)
1416 size
= XINT (Vprint_length
);
1418 for (i
= 0; i
< size
; i
++)
1420 if (i
) PRINTCHAR (' ');
1421 tem
= XVECTOR (obj
)->contents
[i
];
1422 print (tem
, printcharfun
, escapeflag
);
1431 switch (XMISCTYPE (obj
))
1433 case Lisp_Misc_Marker
:
1434 strout ("#<marker ", -1, printcharfun
);
1436 /* Do you think this is necessary? */
1437 if (XMARKER (obj
)->insertion_type
!= 0)
1438 strout ("(before-insertion) ", -1, printcharfun
);
1440 if (!(XMARKER (obj
)->buffer
))
1441 strout ("in no buffer", -1, printcharfun
);
1444 sprintf (buf
, "at %d", marker_position (obj
));
1445 strout (buf
, -1, printcharfun
);
1446 strout (" in ", -1, printcharfun
);
1447 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
1452 case Lisp_Misc_Overlay
:
1453 strout ("#<overlay ", -1, printcharfun
);
1454 if (!(XMARKER (OVERLAY_START (obj
))->buffer
))
1455 strout ("in no buffer", -1, printcharfun
);
1458 sprintf (buf
, "from %d to %d in ",
1459 marker_position (OVERLAY_START (obj
)),
1460 marker_position (OVERLAY_END (obj
)));
1461 strout (buf
, -1, printcharfun
);
1462 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
1468 /* Remaining cases shouldn't happen in normal usage, but let's print
1469 them anyway for the benefit of the debugger. */
1470 case Lisp_Misc_Free
:
1471 strout ("#<misc free cell>", -1, printcharfun
);
1474 case Lisp_Misc_Intfwd
:
1475 sprintf (buf
, "#<intfwd to %d>", *XINTFWD (obj
)->intvar
);
1476 strout (buf
, -1, printcharfun
);
1479 case Lisp_Misc_Boolfwd
:
1480 sprintf (buf
, "#<boolfwd to %s>",
1481 (*XBOOLFWD (obj
)->boolvar
? "t" : "nil"));
1482 strout (buf
, -1, printcharfun
);
1485 case Lisp_Misc_Objfwd
:
1486 strout ("#<objfwd to ", -1, printcharfun
);
1487 print (*XOBJFWD (obj
)->objvar
, printcharfun
, escapeflag
);
1491 case Lisp_Misc_Buffer_Objfwd
:
1492 strout ("#<buffer_objfwd to ", -1, printcharfun
);
1493 print (*(Lisp_Object
*)((char *)current_buffer
1494 + XBUFFER_OBJFWD (obj
)->offset
),
1495 printcharfun
, escapeflag
);
1499 case Lisp_Misc_Kboard_Objfwd
:
1500 strout ("#<kboard_objfwd to ", -1, printcharfun
);
1501 print (*(Lisp_Object
*)((char *) current_kboard
1502 + XKBOARD_OBJFWD (obj
)->offset
),
1503 printcharfun
, escapeflag
);
1507 case Lisp_Misc_Buffer_Local_Value
:
1508 strout ("#<buffer_local_value ", -1, printcharfun
);
1509 goto do_buffer_local
;
1510 case Lisp_Misc_Some_Buffer_Local_Value
:
1511 strout ("#<some_buffer_local_value ", -1, printcharfun
);
1513 strout ("[realvalue] ", -1, printcharfun
);
1514 print (XBUFFER_LOCAL_VALUE (obj
)->car
, printcharfun
, escapeflag
);
1515 strout ("[buffer] ", -1, printcharfun
);
1516 print (XCONS (XBUFFER_LOCAL_VALUE (obj
)->cdr
)->car
,
1517 printcharfun
, escapeflag
);
1518 strout ("[alist-elt] ", -1, printcharfun
);
1519 print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj
)->cdr
)->cdr
)->car
,
1520 printcharfun
, escapeflag
);
1521 strout ("[default-value] ", -1, printcharfun
);
1522 print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj
)->cdr
)->cdr
)->cdr
,
1523 printcharfun
, escapeflag
);
1531 #endif /* standalone */
1536 /* We're in trouble if this happens!
1537 Probably should just abort () */
1538 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, printcharfun
);
1540 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
1541 else if (VECTORLIKEP (obj
))
1542 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
1544 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
1545 strout (buf
, -1, printcharfun
);
1546 strout (" Save your buffers immediately and please report this bug>",
1554 #ifdef USE_TEXT_PROPERTIES
1556 /* Print a description of INTERVAL using PRINTCHARFUN.
1557 This is part of printing a string that has text properties. */
1560 print_interval (interval
, printcharfun
)
1562 Lisp_Object printcharfun
;
1565 print (make_number (interval
->position
), printcharfun
, 1);
1567 print (make_number (interval
->position
+ LENGTH (interval
)),
1570 print (interval
->plist
, printcharfun
, 1);
1573 #endif /* USE_TEXT_PROPERTIES */
1578 DEFVAR_LISP ("standard-output", &Vstandard_output
,
1579 "Output stream `print' uses by default for outputting a character.\n\
1580 This may be any function of one argument.\n\
1581 It may also be a buffer (output is inserted before point)\n\
1582 or a marker (output is inserted and the marker is advanced)\n\
1583 or the symbol t (output appears in the echo area).");
1584 Vstandard_output
= Qt
;
1585 Qstandard_output
= intern ("standard-output");
1586 staticpro (&Qstandard_output
);
1588 #ifdef LISP_FLOAT_TYPE
1589 DEFVAR_LISP ("float-output-format", &Vfloat_output_format
,
1590 "The format descriptor string used to print floats.\n\
1591 This is a %-spec like those accepted by `printf' in C,\n\
1592 but with some restrictions. It must start with the two characters `%.'.\n\
1593 After that comes an integer precision specification,\n\
1594 and then a letter which controls the format.\n\
1595 The letters allowed are `e', `f' and `g'.\n\
1596 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"\n\
1597 Use `f' for decimal point notation \"DIGITS.DIGITS\".\n\
1598 Use `g' to choose the shorter of those two formats for the number at hand.\n\
1599 The precision in any of these cases is the number of digits following\n\
1600 the decimal point. With `f', a precision of 0 means to omit the\n\
1601 decimal point. 0 is not allowed with `e' or `g'.\n\n\
1602 A value of nil means to use the shortest notation\n\
1603 that represents the number without losing information.");
1604 Vfloat_output_format
= Qnil
;
1605 Qfloat_output_format
= intern ("float-output-format");
1606 staticpro (&Qfloat_output_format
);
1607 #endif /* LISP_FLOAT_TYPE */
1609 DEFVAR_LISP ("print-length", &Vprint_length
,
1610 "Maximum length of list to print before abbreviating.\n\
1611 A value of nil means no limit.");
1612 Vprint_length
= Qnil
;
1614 DEFVAR_LISP ("print-level", &Vprint_level
,
1615 "Maximum depth of list nesting to print before abbreviating.\n\
1616 A value of nil means no limit.");
1617 Vprint_level
= Qnil
;
1619 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines
,
1620 "Non-nil means print newlines in strings as backslash-n.\n\
1621 Also print formfeeds as backslash-f.");
1622 print_escape_newlines
= 0;
1624 DEFVAR_BOOL ("print-quoted", &print_quoted
,
1625 "Non-nil means print quoted forms with reader syntax.\n\
1626 I.e., (quote foo) prints as 'foo, (function foo) as #'foo, and, backquoted\n\
1627 forms print in the new syntax.");
1630 DEFVAR_LISP ("print-gensym", &Vprint_gensym
,
1631 "Non-nil means print uninterned symbols so they will read as uninterned.\n\
1632 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.\n\
1633 When the uninterned symbol appears within a larger data structure,\n\
1634 in addition use the #...# and #...= constructs as needed,\n\
1635 so that multiple references to the same symbol are shared once again\n\
1636 when the text is read back.\n\
1638 If the value of `print-gensym' is a cons cell, then in addition refrain from\n\
1639 clearing `print-gensym-alist' on entry to and exit from printing functions,\n\
1640 so that the use of #...# and #...= can carry over for several separately\n\
1642 Vprint_gensym
= Qnil
;
1644 DEFVAR_LISP ("print-gensym-alist", &Vprint_gensym_alist
,
1645 "Association list of elements (GENSYM . N) to guide use of #N# and #N=.\n\
1646 In each element, GENSYM is an uninterned symbol that has been associated\n\
1647 with #N= for the specified value of N.");
1648 Vprint_gensym_alist
= Qnil
;
1650 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
1651 staticpro (&Vprin1_to_string_buffer
);
1654 defsubr (&Sprin1_to_string
);
1655 defsubr (&Serror_message_string
);
1659 defsubr (&Swrite_char
);
1660 defsubr (&Sexternal_debugging_output
);
1662 Qexternal_debugging_output
= intern ("external-debugging-output");
1663 staticpro (&Qexternal_debugging_output
);
1665 Qprint_escape_newlines
= intern ("print-escape-newlines");
1666 staticpro (&Qprint_escape_newlines
);
1669 defsubr (&Swith_output_to_temp_buffer
);
1670 #endif /* not standalone */