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 specpdl_count = specpdl_ptr - specpdl; \
226 int free_print_buffer = 0; \
229 #define PRINTPREPARE \
230 original = printcharfun; \
231 if (NILP (printcharfun)) printcharfun = Qt; \
232 if (BUFFERP (printcharfun)) \
234 if (XBUFFER (printcharfun) != current_buffer) \
235 Fset_buffer (printcharfun); \
236 printcharfun = Qnil; \
238 if (MARKERP (printcharfun)) \
240 if (!(XMARKER (original)->buffer)) \
241 error ("Marker does not point anywhere"); \
242 if (XMARKER (original)->buffer != current_buffer) \
243 set_buffer_internal (XMARKER (original)->buffer); \
245 SET_PT (marker_position (printcharfun)); \
247 printcharfun = Qnil; \
249 if (NILP (printcharfun)) \
251 if (print_buffer != 0) \
252 record_unwind_protect (print_unwind, \
253 make_string (print_buffer, \
254 print_buffer_pos)); \
257 print_buffer_size = 1000; \
258 print_buffer = (char *) xmalloc (print_buffer_size); \
259 free_print_buffer = 1; \
261 print_buffer_pos = 0; \
263 if (!CONSP (Vprint_gensym)) \
264 Vprint_gensym_alist = Qnil
266 #define PRINTFINISH \
267 if (NILP (printcharfun)) \
268 insert (print_buffer, print_buffer_pos); \
269 if (free_print_buffer) \
271 xfree (print_buffer); \
274 unbind_to (specpdl_count, Qnil); \
275 if (MARKERP (original)) \
276 Fset_marker (original, make_number (PT), Qnil); \
277 if (old_point >= 0) \
278 SET_PT (old_point + (old_point >= start_point \
279 ? PT - start_point : 0)); \
280 if (old != current_buffer) \
281 set_buffer_internal (old); \
282 if (!CONSP (Vprint_gensym)) \
283 Vprint_gensym_alist = Qnil
285 #define PRINTCHAR(ch) printchar (ch, printcharfun)
287 /* Nonzero if there is no room to print any more characters
288 so print might as well return right away. */
290 #define PRINTFULLP() \
291 (EQ (printcharfun, Qt) && !noninteractive \
292 && printbufidx >= FRAME_WIDTH (XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window)))))
294 /* This is used to restore the saved contents of print_buffer
295 when there is a recursive call to print. */
297 print_unwind (saved_text
)
298 Lisp_Object saved_text
;
300 bcopy (XSTRING (saved_text
)->data
, print_buffer
, XSTRING (saved_text
)->size
);
303 /* Index of first unused element of FRAME_MESSAGE_BUF (mini_frame). */
304 static int printbufidx
;
313 #ifdef MAX_PRINT_CHARS
316 #endif /* MAX_PRINT_CHARS */
321 unsigned char work
[4], *str
;
324 len
= CHAR_STRING (ch
, work
, str
);
325 if (print_buffer_pos
+ len
>= print_buffer_size
)
326 print_buffer
= (char *) xrealloc (print_buffer
,
327 print_buffer_size
*= 2);
328 bcopy (str
, print_buffer
+ print_buffer_pos
, len
);
329 print_buffer_pos
+= len
;
336 = XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window
)));
337 unsigned char work
[4], *str
;
338 int len
= CHAR_STRING (ch
, work
, str
);
345 putchar (*str
), str
++;
346 noninteractive_need_newline
= 1;
350 if (echo_area_glyphs
!= FRAME_MESSAGE_BUF (mini_frame
)
351 || !message_buf_print
)
353 message_log_maybe_newline ();
354 echo_area_glyphs
= FRAME_MESSAGE_BUF (mini_frame
);
356 echo_area_glyphs_length
= 0;
357 message_buf_print
= 1;
359 if (minibuffer_auto_raise
)
361 Lisp_Object mini_window
;
363 /* Get the frame containing the minibuffer
364 that the selected frame is using. */
365 mini_window
= FRAME_MINIBUF_WINDOW (selected_frame
);
367 Fraise_frame (WINDOW_FRAME (XWINDOW (mini_window
)));
371 message_dolog (str
, len
, 0);
372 if (printbufidx
< FRAME_MESSAGE_BUF_SIZE (mini_frame
) - len
)
373 bcopy (str
, &FRAME_MESSAGE_BUF (mini_frame
)[printbufidx
], len
),
375 FRAME_MESSAGE_BUF (mini_frame
)[printbufidx
] = 0;
376 echo_area_glyphs_length
= printbufidx
;
380 #endif /* not standalone */
382 XSETFASTINT (ch1
, ch
);
387 strout (ptr
, size
, printcharfun
)
390 Lisp_Object printcharfun
;
397 if (EQ (printcharfun
, Qnil
))
399 if (print_buffer_pos
+ size
> print_buffer_size
)
401 print_buffer_size
= print_buffer_size
* 2 + size
;
402 print_buffer
= (char *) xrealloc (print_buffer
,
405 bcopy (ptr
, print_buffer
+ print_buffer_pos
, size
);
406 print_buffer_pos
+= size
;
408 #ifdef MAX_PRINT_CHARS
411 #endif /* MAX_PRINT_CHARS */
414 if (EQ (printcharfun
, Qt
))
417 = XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window
)));
421 #ifdef MAX_PRINT_CHARS
424 #endif /* MAX_PRINT_CHARS */
428 fwrite (ptr
, 1, size
, stdout
);
429 noninteractive_need_newline
= 1;
433 if (echo_area_glyphs
!= FRAME_MESSAGE_BUF (mini_frame
)
434 || !message_buf_print
)
436 message_log_maybe_newline ();
437 echo_area_glyphs
= FRAME_MESSAGE_BUF (mini_frame
);
439 echo_area_glyphs_length
= 0;
440 message_buf_print
= 1;
442 if (minibuffer_auto_raise
)
444 Lisp_Object mini_window
;
446 /* Get the frame containing the minibuffer
447 that the selected frame is using. */
448 mini_window
= FRAME_MINIBUF_WINDOW (selected_frame
);
450 Fraise_frame (WINDOW_FRAME (XWINDOW (mini_window
)));
454 message_dolog (ptr
, size
, 0);
455 if (size
> FRAME_MESSAGE_BUF_SIZE (mini_frame
) - printbufidx
- 1)
457 size
= FRAME_MESSAGE_BUF_SIZE (mini_frame
) - printbufidx
- 1;
458 /* Rewind incomplete multi-byte form. */
459 while (size
&& (unsigned char) ptr
[size
] >= 0xA0) size
--;
461 bcopy (ptr
, &FRAME_MESSAGE_BUF (mini_frame
) [printbufidx
], size
);
463 echo_area_glyphs_length
= printbufidx
;
464 FRAME_MESSAGE_BUF (mini_frame
) [printbufidx
] = 0;
472 /* Here, we must convert each multi-byte form to the
473 corresponding character code before handing it to PRINTCHAR. */
475 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size
- i
, len
);
482 /* Print the contents of a string STRING using PRINTCHARFUN.
483 It isn't safe to use strout in many cases,
484 because printing one char can relocate. */
487 print_string (string
, printcharfun
)
489 Lisp_Object printcharfun
;
491 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
492 /* strout is safe for output to a frame (echo area) or to print_buffer. */
493 strout (XSTRING (string
)->data
, XSTRING (string
)->size
, printcharfun
);
496 /* Otherwise, fetch the string address for each character. */
498 int size
= XSTRING (string
)->size
;
501 for (i
= 0; i
< size
; i
++)
502 PRINTCHAR (XSTRING (string
)->data
[i
]);
507 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
508 "Output character CHARACTER to stream PRINTCHARFUN.\n\
509 PRINTCHARFUN defaults to the value of `standard-output' (which see).")
510 (character
, printcharfun
)
511 Lisp_Object character
, printcharfun
;
515 if (NILP (printcharfun
))
516 printcharfun
= Vstandard_output
;
517 CHECK_NUMBER (character
, 0);
519 PRINTCHAR (XINT (character
));
524 /* Used from outside of print.c to print a block of SIZE chars at DATA
525 on the default output stream.
526 Do not use this on the contents of a Lisp string. */
529 write_string (data
, size
)
534 Lisp_Object printcharfun
;
536 printcharfun
= Vstandard_output
;
539 strout (data
, size
, printcharfun
);
543 /* Used from outside of print.c to print a block of SIZE chars at DATA
544 on a specified stream PRINTCHARFUN.
545 Do not use this on the contents of a Lisp string. */
548 write_string_1 (data
, size
, printcharfun
)
551 Lisp_Object printcharfun
;
556 strout (data
, size
, printcharfun
);
564 temp_output_buffer_setup (bufname
)
567 register struct buffer
*old
= current_buffer
;
568 register Lisp_Object buf
;
570 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
572 current_buffer
->directory
= old
->directory
;
573 current_buffer
->read_only
= Qnil
;
576 XSETBUFFER (buf
, current_buffer
);
577 specbind (Qstandard_output
, buf
);
579 set_buffer_internal (old
);
583 internal_with_output_to_temp_buffer (bufname
, function
, args
)
585 Lisp_Object (*function
) ();
588 int count
= specpdl_ptr
- specpdl
;
589 Lisp_Object buf
, val
;
593 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
594 temp_output_buffer_setup (bufname
);
595 buf
= Vstandard_output
;
598 val
= (*function
) (args
);
601 temp_output_buffer_show (buf
);
604 return unbind_to (count
, val
);
607 DEFUN ("with-output-to-temp-buffer", Fwith_output_to_temp_buffer
, Swith_output_to_temp_buffer
,
609 "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.\n\
610 The buffer is cleared out initially, and marked as unmodified when done.\n\
611 All output done by BODY is inserted in that buffer by default.\n\
612 The buffer is displayed in another window, but not selected.\n\
613 The value of the last form in BODY is returned.\n\
614 If BODY does not finish normally, the buffer BUFNAME is not displayed.\n\n\
615 If variable `temp-buffer-show-function' is non-nil, call it at the end\n\
616 to get the buffer displayed. It gets one argument, the buffer to display.")
622 int count
= specpdl_ptr
- specpdl
;
623 Lisp_Object buf
, val
;
626 name
= Feval (Fcar (args
));
629 CHECK_STRING (name
, 0);
630 temp_output_buffer_setup (XSTRING (name
)->data
);
631 buf
= Vstandard_output
;
633 val
= Fprogn (Fcdr (args
));
635 temp_output_buffer_show (buf
);
637 return unbind_to (count
, val
);
639 #endif /* not standalone */
641 static void print ();
643 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
644 "Output a newline to stream PRINTCHARFUN.\n\
645 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used.")
647 Lisp_Object printcharfun
;
651 if (NILP (printcharfun
))
652 printcharfun
= Vstandard_output
;
659 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
660 "Output the printed representation of OBJECT, any Lisp object.\n\
661 Quoting characters are printed when needed to make output that `read'\n\
662 can handle, whenever this is possible.\n\
663 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
664 (object
, printcharfun
)
665 Lisp_Object object
, printcharfun
;
669 #ifdef MAX_PRINT_CHARS
671 #endif /* MAX_PRINT_CHARS */
672 if (NILP (printcharfun
))
673 printcharfun
= Vstandard_output
;
676 print (object
, printcharfun
, 1);
681 /* a buffer which is used to hold output being built by prin1-to-string */
682 Lisp_Object Vprin1_to_string_buffer
;
684 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
685 "Return a string containing the printed representation of OBJECT,\n\
686 any Lisp object. Quoting characters are used when needed to make output\n\
687 that `read' can handle, whenever this is possible, unless the optional\n\
688 second argument NOESCAPE is non-nil.")
690 Lisp_Object object
, noescape
;
693 Lisp_Object printcharfun
;
694 struct gcpro gcpro1
, gcpro2
;
697 /* Save and restore this--we are altering a buffer
698 but we don't want to deactivate the mark just for that.
699 No need for specbind, since errors deactivate the mark. */
700 tem
= Vdeactivate_mark
;
701 GCPRO2 (object
, tem
);
703 printcharfun
= Vprin1_to_string_buffer
;
706 print (object
, printcharfun
, NILP (noescape
));
707 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
709 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
710 object
= Fbuffer_string ();
713 set_buffer_internal (old
);
715 Vdeactivate_mark
= tem
;
721 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
722 "Output the printed representation of OBJECT, any Lisp object.\n\
723 No quoting characters are used; no delimiters are printed around\n\
724 the contents of strings.\n\
725 Output stream is PRINTCHARFUN, or value of standard-output (which see).")
726 (object
, printcharfun
)
727 Lisp_Object object
, printcharfun
;
731 if (NILP (printcharfun
))
732 printcharfun
= Vstandard_output
;
735 print (object
, printcharfun
, 0);
740 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
741 "Output the printed representation of OBJECT, with newlines around it.\n\
742 Quoting characters are printed when needed to make output that `read'\n\
743 can handle, whenever this is possible.\n\
744 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
745 (object
, printcharfun
)
746 Lisp_Object object
, printcharfun
;
751 #ifdef MAX_PRINT_CHARS
753 max_print
= MAX_PRINT_CHARS
;
754 #endif /* MAX_PRINT_CHARS */
755 if (NILP (printcharfun
))
756 printcharfun
= Vstandard_output
;
761 print (object
, printcharfun
, 1);
764 #ifdef MAX_PRINT_CHARS
767 #endif /* MAX_PRINT_CHARS */
772 /* The subroutine object for external-debugging-output is kept here
773 for the convenience of the debugger. */
774 Lisp_Object Qexternal_debugging_output
;
776 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
777 "Write CHARACTER to stderr.\n\
778 You can call print while debugging emacs, and pass it this function\n\
779 to make it write to the debugging output.\n")
781 Lisp_Object character
;
783 CHECK_NUMBER (character
, 0);
784 putc (XINT (character
), stderr
);
787 /* Send the output to a debugger (nothing happens if there isn't one). */
789 char buf
[2] = {(char) XINT (character
), '\0'};
790 OutputDebugString (buf
);
797 /* This is the interface for debugging printing. */
803 Fprin1 (arg
, Qexternal_debugging_output
);
804 fprintf (stderr
, "\r\n");
807 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
809 "Convert an error value (ERROR-SYMBOL . DATA) to an error message.")
813 struct buffer
*old
= current_buffer
;
814 Lisp_Object original
, printcharfun
, value
;
817 /* If OBJ is (error STRING), just return STRING.
818 That is not only faster, it also avoids the need to allocate
819 space here when the error is due to memory full. */
820 if (CONSP (obj
) && EQ (XCONS (obj
)->car
, Qerror
)
821 && CONSP (XCONS (obj
)->cdr
)
822 && STRINGP (XCONS (XCONS (obj
)->cdr
)->car
)
823 && NILP (XCONS (XCONS (obj
)->cdr
)->cdr
))
824 return XCONS (XCONS (obj
)->cdr
)->car
;
826 print_error_message (obj
, Vprin1_to_string_buffer
);
828 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
829 value
= Fbuffer_string ();
833 set_buffer_internal (old
);
839 /* Print an error message for the error DATA
840 onto Lisp output stream STREAM (suitable for the print functions). */
843 print_error_message (data
, stream
)
844 Lisp_Object data
, stream
;
846 Lisp_Object errname
, errmsg
, file_error
, tail
;
850 errname
= Fcar (data
);
852 if (EQ (errname
, Qerror
))
855 if (!CONSP (data
)) data
= Qnil
;
856 errmsg
= Fcar (data
);
861 errmsg
= Fget (errname
, Qerror_message
);
862 file_error
= Fmemq (Qfile_error
,
863 Fget (errname
, Qerror_conditions
));
866 /* Print an error message including the data items. */
868 tail
= Fcdr_safe (data
);
871 /* For file-error, make error message by concatenating
872 all the data items. They are all strings. */
873 if (!NILP (file_error
) && !NILP (tail
))
874 errmsg
= XCONS (tail
)->car
, tail
= XCONS (tail
)->cdr
;
876 if (STRINGP (errmsg
))
877 Fprinc (errmsg
, stream
);
879 write_string_1 ("peculiar error", -1, stream
);
881 for (i
= 0; CONSP (tail
); tail
= Fcdr (tail
), i
++)
883 write_string_1 (i
? ", " : ": ", 2, stream
);
884 if (!NILP (file_error
))
885 Fprinc (Fcar (tail
), stream
);
887 Fprin1 (Fcar (tail
), stream
);
892 #ifdef LISP_FLOAT_TYPE
895 * The buffer should be at least as large as the max string size of the
896 * largest float, printed in the biggest notation. This is undoubtedly
897 * 20d float_output_format, with the negative of the C-constant "HUGE"
900 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
902 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
903 * case of -1e307 in 20d float_output_format. What is one to do (short of
904 * re-writing _doprnt to be more sane)?
909 float_to_string (buf
, data
)
916 if (NILP (Vfloat_output_format
)
917 || !STRINGP (Vfloat_output_format
))
920 /* Generate the fewest number of digits that represent the
921 floating point value without losing information.
922 The following method is simple but a bit slow.
923 For ideas about speeding things up, please see:
925 Guy L Steele Jr & Jon L White, How to print floating-point numbers
926 accurately. SIGPLAN notices 25, 6 (June 1990), 112-126.
928 Robert G Burger & R Kent Dybvig, Printing floating point numbers
929 quickly and accurately, SIGPLAN notices 31, 5 (May 1996), 108-116. */
931 width
= fabs (data
) < DBL_MIN
? 1 : DBL_DIG
;
933 sprintf (buf
, "%.*g", width
, data
);
934 while (width
++ < DOUBLE_DIGITS_BOUND
&& atof (buf
) != data
);
938 /* Check that the spec we have is fully valid.
939 This means not only valid for printf,
940 but meant for floats, and reasonable. */
941 cp
= XSTRING (Vfloat_output_format
)->data
;
950 /* Check the width specification. */
952 if ('0' <= *cp
&& *cp
<= '9')
956 width
= (width
* 10) + (*cp
++ - '0');
957 while (*cp
>= '0' && *cp
<= '9');
959 /* A precision of zero is valid only for %f. */
961 || (width
== 0 && *cp
!= 'f'))
965 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
971 sprintf (buf
, XSTRING (Vfloat_output_format
)->data
, data
);
974 /* Make sure there is a decimal point with digit after, or an
975 exponent, so that the value is readable as a float. But don't do
976 this with "%.0f"; it's valid for that not to produce a decimal
977 point. Note that width can be 0 only for %.0f. */
980 for (cp
= buf
; *cp
; cp
++)
981 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
984 if (*cp
== '.' && cp
[1] == 0)
998 #endif /* LISP_FLOAT_TYPE */
1001 print (obj
, printcharfun
, escapeflag
)
1003 register Lisp_Object printcharfun
;
1010 #if 1 /* I'm not sure this is really worth doing. */
1011 /* Detect circularities and truncate them.
1012 No need to offer any alternative--this is better than an error. */
1013 if (CONSP (obj
) || VECTORP (obj
) || COMPILEDP (obj
))
1016 for (i
= 0; i
< print_depth
; i
++)
1017 if (EQ (obj
, being_printed
[i
]))
1019 sprintf (buf
, "#%d", i
);
1020 strout (buf
, -1, printcharfun
);
1026 being_printed
[print_depth
] = obj
;
1029 if (print_depth
> PRINT_CIRCLE
)
1030 error ("Apparently circular structure being printed");
1031 #ifdef MAX_PRINT_CHARS
1032 if (max_print
&& print_chars
> max_print
)
1037 #endif /* MAX_PRINT_CHARS */
1039 switch (XGCTYPE (obj
))
1042 if (sizeof (int) == sizeof (EMACS_INT
))
1043 sprintf (buf
, "%d", XINT (obj
));
1044 else if (sizeof (long) == sizeof (EMACS_INT
))
1045 sprintf (buf
, "%ld", XINT (obj
));
1048 strout (buf
, -1, printcharfun
);
1051 #ifdef LISP_FLOAT_TYPE
1054 char pigbuf
[350]; /* see comments in float_to_string */
1056 float_to_string (pigbuf
, XFLOAT(obj
)->data
);
1057 strout (pigbuf
, -1, printcharfun
);
1064 print_string (obj
, printcharfun
);
1068 register unsigned char c
;
1069 struct gcpro gcpro1
;
1073 #ifdef USE_TEXT_PROPERTIES
1074 if (!NULL_INTERVAL_P (XSTRING (obj
)->intervals
))
1082 for (i
= 0; i
< XSTRING (obj
)->size
; i
++)
1085 c
= XSTRING (obj
)->data
[i
];
1086 if (c
== '\n' && print_escape_newlines
)
1091 else if (c
== '\f' && print_escape_newlines
)
1098 if (c
== '\"' || c
== '\\')
1105 #ifdef USE_TEXT_PROPERTIES
1106 if (!NULL_INTERVAL_P (XSTRING (obj
)->intervals
))
1108 traverse_intervals (XSTRING (obj
)->intervals
,
1109 0, 0, print_interval
, printcharfun
);
1120 register int confusing
;
1121 register unsigned char *p
= XSYMBOL (obj
)->name
->data
;
1122 register unsigned char *end
= p
+ XSYMBOL (obj
)->name
->size
;
1123 register unsigned char c
;
1126 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1129 /* If symbol name begins with a digit, and ends with a digit,
1130 and contains nothing but digits and `e', it could be treated
1131 as a number. So set CONFUSING.
1133 Symbols that contain periods could also be taken as numbers,
1134 but periods are always escaped, so we don't have to worry
1136 else if (*p
>= '0' && *p
<= '9'
1137 && end
[-1] >= '0' && end
[-1] <= '9')
1139 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1140 /* Needed for \2e10. */
1143 confusing
= (end
== p
);
1148 /* If we print an uninterned symbol as part of a complex object and
1149 the flag print-gensym is non-nil, prefix it with #n= to read the
1150 object back with the #n# reader syntax later if needed. */
1151 if (! NILP (Vprint_gensym
) && NILP (XSYMBOL (obj
)->obarray
))
1153 if (print_depth
> 1)
1156 tem
= Fassq (obj
, Vprint_gensym_alist
);
1160 print (XCDR (tem
), printcharfun
, escapeflag
);
1166 if (CONSP (Vprint_gensym_alist
))
1167 XSETFASTINT (tem
, XFASTINT (XCDR (XCAR (Vprint_gensym_alist
))) + 1);
1169 XSETFASTINT (tem
, 1);
1170 Vprint_gensym_alist
= Fcons (Fcons (obj
, tem
), Vprint_gensym_alist
);
1173 print (tem
, printcharfun
, escapeflag
);
1181 for (i
= 0; i
< XSYMBOL (obj
)->name
->size
; i
++)
1184 c
= XSYMBOL (obj
)->name
->data
[i
];
1188 if (c
== '\"' || c
== '\\' || c
== '\''
1189 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1190 || c
== ',' || c
=='.' || c
== '`'
1191 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1193 PRINTCHAR ('\\'), confusing
= 0;
1201 /* If deeper than spec'd depth, print placeholder. */
1202 if (INTEGERP (Vprint_level
)
1203 && print_depth
> XINT (Vprint_level
))
1204 strout ("...", -1, printcharfun
);
1205 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1206 && (EQ (XCAR (obj
), Qquote
)))
1209 print (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1211 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1212 && (EQ (XCAR (obj
), Qfunction
)))
1216 print (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1218 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1219 && ((EQ (XCAR (obj
), Qbackquote
)
1220 || EQ (XCAR (obj
), Qcomma
)
1221 || EQ (XCAR (obj
), Qcomma_at
)
1222 || EQ (XCAR (obj
), Qcomma_dot
))))
1224 print (XCAR (obj
), printcharfun
, 0);
1225 print (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1232 register int max
= 0;
1234 if (INTEGERP (Vprint_length
))
1235 max
= XINT (Vprint_length
);
1236 /* Could recognize circularities in cdrs here,
1237 but that would make printing of long lists quadratic.
1238 It's not worth doing. */
1245 strout ("...", 3, printcharfun
);
1248 print (XCAR (obj
), printcharfun
, escapeflag
);
1254 strout (" . ", 3, printcharfun
);
1255 print (obj
, printcharfun
, escapeflag
);
1261 case Lisp_Vectorlike
:
1266 strout ("#<process ", -1, printcharfun
);
1267 print_string (XPROCESS (obj
)->name
, printcharfun
);
1271 print_string (XPROCESS (obj
)->name
, printcharfun
);
1273 else if (BOOL_VECTOR_P (obj
))
1276 register unsigned char c
;
1277 struct gcpro gcpro1
;
1279 = (XBOOL_VECTOR (obj
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1285 sprintf (buf
, "%d", XBOOL_VECTOR (obj
)->size
);
1286 strout (buf
, -1, printcharfun
);
1289 /* Don't print more characters than the specified maximum. */
1290 if (INTEGERP (Vprint_length
)
1291 && XINT (Vprint_length
) < size_in_chars
)
1292 size_in_chars
= XINT (Vprint_length
);
1294 for (i
= 0; i
< size_in_chars
; i
++)
1297 c
= XBOOL_VECTOR (obj
)->data
[i
];
1298 if (c
== '\n' && print_escape_newlines
)
1303 else if (c
== '\f' && print_escape_newlines
)
1310 if (c
== '\"' || c
== '\\')
1319 else if (SUBRP (obj
))
1321 strout ("#<subr ", -1, printcharfun
);
1322 strout (XSUBR (obj
)->symbol_name
, -1, printcharfun
);
1326 else if (WINDOWP (obj
))
1328 strout ("#<window ", -1, printcharfun
);
1329 sprintf (buf
, "%d", XFASTINT (XWINDOW (obj
)->sequence_number
));
1330 strout (buf
, -1, printcharfun
);
1331 if (!NILP (XWINDOW (obj
)->buffer
))
1333 strout (" on ", -1, printcharfun
);
1334 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1338 else if (BUFFERP (obj
))
1340 if (NILP (XBUFFER (obj
)->name
))
1341 strout ("#<killed buffer>", -1, printcharfun
);
1342 else if (escapeflag
)
1344 strout ("#<buffer ", -1, printcharfun
);
1345 print_string (XBUFFER (obj
)->name
, printcharfun
);
1349 print_string (XBUFFER (obj
)->name
, printcharfun
);
1351 else if (WINDOW_CONFIGURATIONP (obj
))
1353 strout ("#<window-configuration>", -1, printcharfun
);
1355 else if (FRAMEP (obj
))
1357 strout ((FRAME_LIVE_P (XFRAME (obj
))
1358 ? "#<frame " : "#<dead frame "),
1360 print_string (XFRAME (obj
)->name
, printcharfun
);
1361 sprintf (buf
, " 0x%lx", (unsigned long) (XFRAME (obj
)));
1362 strout (buf
, -1, printcharfun
);
1365 #endif /* not standalone */
1368 int size
= XVECTOR (obj
)->size
;
1369 if (COMPILEDP (obj
))
1372 size
&= PSEUDOVECTOR_SIZE_MASK
;
1374 if (CHAR_TABLE_P (obj
))
1376 /* We print a char-table as if it were a vector,
1377 lumping the parent and default slots in with the
1378 character slots. But we add #^ as a prefix. */
1381 if (SUB_CHAR_TABLE_P (obj
))
1383 size
&= PSEUDOVECTOR_SIZE_MASK
;
1385 if (size
& PSEUDOVECTOR_FLAG
)
1391 register Lisp_Object tem
;
1393 /* Don't print more elements than the specified maximum. */
1394 if (INTEGERP (Vprint_length
)
1395 && XINT (Vprint_length
) < size
)
1396 size
= XINT (Vprint_length
);
1398 for (i
= 0; i
< size
; i
++)
1400 if (i
) PRINTCHAR (' ');
1401 tem
= XVECTOR (obj
)->contents
[i
];
1402 print (tem
, printcharfun
, escapeflag
);
1411 switch (XMISCTYPE (obj
))
1413 case Lisp_Misc_Marker
:
1414 strout ("#<marker ", -1, printcharfun
);
1416 /* Do you think this is necessary? */
1417 if (XMARKER (obj
)->insertion_type
!= 0)
1418 strout ("(before-insertion) ", -1, printcharfun
);
1420 if (!(XMARKER (obj
)->buffer
))
1421 strout ("in no buffer", -1, printcharfun
);
1424 sprintf (buf
, "at %d", marker_position (obj
));
1425 strout (buf
, -1, printcharfun
);
1426 strout (" in ", -1, printcharfun
);
1427 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
1432 case Lisp_Misc_Overlay
:
1433 strout ("#<overlay ", -1, printcharfun
);
1434 if (!(XMARKER (OVERLAY_START (obj
))->buffer
))
1435 strout ("in no buffer", -1, printcharfun
);
1438 sprintf (buf
, "from %d to %d in ",
1439 marker_position (OVERLAY_START (obj
)),
1440 marker_position (OVERLAY_END (obj
)));
1441 strout (buf
, -1, printcharfun
);
1442 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
1448 /* Remaining cases shouldn't happen in normal usage, but let's print
1449 them anyway for the benefit of the debugger. */
1450 case Lisp_Misc_Free
:
1451 strout ("#<misc free cell>", -1, printcharfun
);
1454 case Lisp_Misc_Intfwd
:
1455 sprintf (buf
, "#<intfwd to %d>", *XINTFWD (obj
)->intvar
);
1456 strout (buf
, -1, printcharfun
);
1459 case Lisp_Misc_Boolfwd
:
1460 sprintf (buf
, "#<boolfwd to %s>",
1461 (*XBOOLFWD (obj
)->boolvar
? "t" : "nil"));
1462 strout (buf
, -1, printcharfun
);
1465 case Lisp_Misc_Objfwd
:
1466 strout ("#<objfwd to ", -1, printcharfun
);
1467 print (*XOBJFWD (obj
)->objvar
, printcharfun
, escapeflag
);
1471 case Lisp_Misc_Buffer_Objfwd
:
1472 strout ("#<buffer_objfwd to ", -1, printcharfun
);
1473 print (*(Lisp_Object
*)((char *)current_buffer
1474 + XBUFFER_OBJFWD (obj
)->offset
),
1475 printcharfun
, escapeflag
);
1479 case Lisp_Misc_Kboard_Objfwd
:
1480 strout ("#<kboard_objfwd to ", -1, printcharfun
);
1481 print (*(Lisp_Object
*)((char *) current_kboard
1482 + XKBOARD_OBJFWD (obj
)->offset
),
1483 printcharfun
, escapeflag
);
1487 case Lisp_Misc_Buffer_Local_Value
:
1488 strout ("#<buffer_local_value ", -1, printcharfun
);
1489 goto do_buffer_local
;
1490 case Lisp_Misc_Some_Buffer_Local_Value
:
1491 strout ("#<some_buffer_local_value ", -1, printcharfun
);
1493 strout ("[realvalue] ", -1, printcharfun
);
1494 print (XBUFFER_LOCAL_VALUE (obj
)->car
, printcharfun
, escapeflag
);
1495 strout ("[buffer] ", -1, printcharfun
);
1496 print (XCONS (XBUFFER_LOCAL_VALUE (obj
)->cdr
)->car
,
1497 printcharfun
, escapeflag
);
1498 strout ("[alist-elt] ", -1, printcharfun
);
1499 print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj
)->cdr
)->cdr
)->car
,
1500 printcharfun
, escapeflag
);
1501 strout ("[default-value] ", -1, printcharfun
);
1502 print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj
)->cdr
)->cdr
)->cdr
,
1503 printcharfun
, escapeflag
);
1511 #endif /* standalone */
1516 /* We're in trouble if this happens!
1517 Probably should just abort () */
1518 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, printcharfun
);
1520 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
1521 else if (VECTORLIKEP (obj
))
1522 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
1524 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
1525 strout (buf
, -1, printcharfun
);
1526 strout (" Save your buffers immediately and please report this bug>",
1534 #ifdef USE_TEXT_PROPERTIES
1536 /* Print a description of INTERVAL using PRINTCHARFUN.
1537 This is part of printing a string that has text properties. */
1540 print_interval (interval
, printcharfun
)
1542 Lisp_Object printcharfun
;
1545 print (make_number (interval
->position
), printcharfun
, 1);
1547 print (make_number (interval
->position
+ LENGTH (interval
)),
1550 print (interval
->plist
, printcharfun
, 1);
1553 #endif /* USE_TEXT_PROPERTIES */
1558 DEFVAR_LISP ("standard-output", &Vstandard_output
,
1559 "Output stream `print' uses by default for outputting a character.\n\
1560 This may be any function of one argument.\n\
1561 It may also be a buffer (output is inserted before point)\n\
1562 or a marker (output is inserted and the marker is advanced)\n\
1563 or the symbol t (output appears in the echo area).");
1564 Vstandard_output
= Qt
;
1565 Qstandard_output
= intern ("standard-output");
1566 staticpro (&Qstandard_output
);
1568 #ifdef LISP_FLOAT_TYPE
1569 DEFVAR_LISP ("float-output-format", &Vfloat_output_format
,
1570 "The format descriptor string used to print floats.\n\
1571 This is a %-spec like those accepted by `printf' in C,\n\
1572 but with some restrictions. It must start with the two characters `%.'.\n\
1573 After that comes an integer precision specification,\n\
1574 and then a letter which controls the format.\n\
1575 The letters allowed are `e', `f' and `g'.\n\
1576 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"\n\
1577 Use `f' for decimal point notation \"DIGITS.DIGITS\".\n\
1578 Use `g' to choose the shorter of those two formats for the number at hand.\n\
1579 The precision in any of these cases is the number of digits following\n\
1580 the decimal point. With `f', a precision of 0 means to omit the\n\
1581 decimal point. 0 is not allowed with `e' or `g'.\n\n\
1582 A value of nil means to use the shortest notation\n\
1583 that represents the number without losing information.");
1584 Vfloat_output_format
= Qnil
;
1585 Qfloat_output_format
= intern ("float-output-format");
1586 staticpro (&Qfloat_output_format
);
1587 #endif /* LISP_FLOAT_TYPE */
1589 DEFVAR_LISP ("print-length", &Vprint_length
,
1590 "Maximum length of list to print before abbreviating.\n\
1591 A value of nil means no limit.");
1592 Vprint_length
= Qnil
;
1594 DEFVAR_LISP ("print-level", &Vprint_level
,
1595 "Maximum depth of list nesting to print before abbreviating.\n\
1596 A value of nil means no limit.");
1597 Vprint_level
= Qnil
;
1599 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines
,
1600 "Non-nil means print newlines in strings as backslash-n.\n\
1601 Also print formfeeds as backslash-f.");
1602 print_escape_newlines
= 0;
1604 DEFVAR_BOOL ("print-quoted", &print_quoted
,
1605 "Non-nil means print quoted forms with reader syntax.\n\
1606 I.e., (quote foo) prints as 'foo, (function foo) as #'foo, and, backquoted\n\
1607 forms print in the new syntax.");
1610 DEFVAR_LISP ("print-gensym", &Vprint_gensym
,
1611 "Non-nil means print uninterned symbols so they will read as uninterned.\n\
1612 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.\n\
1613 When the uninterned symbol appears within a larger data structure,\n\
1614 in addition use the #...# and #...= constructs as needed,\n\
1615 so that multiple references to the same symbol are shared once again\n\
1616 when the text is read back.\n\
1618 If the value of `print-gensym' is a cons cell, then in addition refrain from\n\
1619 clearing `print-gensym-alist' on entry to and exit from printing functions,\n\
1620 so that the use of #...# and #...= can carry over for several separately\n\
1622 Vprint_gensym
= Qnil
;
1624 DEFVAR_LISP ("print-gensym-alist", &Vprint_gensym_alist
,
1625 "Association list of elements (GENSYM . N) to guide use of #N# and #N=.\n\
1626 In each element, GENSYM is an uninterned symbol that has been associated\n\
1627 with #N= for the specified value of N.");
1628 Vprint_gensym_alist
= Qnil
;
1630 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
1631 staticpro (&Vprin1_to_string_buffer
);
1634 defsubr (&Sprin1_to_string
);
1635 defsubr (&Serror_message_string
);
1639 defsubr (&Swrite_char
);
1640 defsubr (&Sexternal_debugging_output
);
1642 Qexternal_debugging_output
= intern ("external-debugging-output");
1643 staticpro (&Qexternal_debugging_output
);
1645 Qprint_escape_newlines
= intern ("print-escape-newlines");
1646 staticpro (&Qprint_escape_newlines
);
1649 defsubr (&Swith_output_to_temp_buffer
);
1650 #endif /* not standalone */