1 /* Lisp object printing and output streams.
2 Copyright (C) 1985, 86, 88, 93, 94, 95 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
;
48 #endif /* LISP_FLOAT_TYPE */
50 /* Avoid actual stack overflow in print. */
53 /* Detect most circularities to print finite output. */
54 #define PRINT_CIRCLE 200
55 Lisp_Object being_printed
[PRINT_CIRCLE
];
57 /* When printing into a buffer, first we put the text in this
58 block, then insert it all at once. */
61 /* Size allocated in print_buffer. */
62 int print_buffer_size
;
63 /* Size used in print_buffer. */
66 /* Maximum length of list to print in full; noninteger means
67 effectively infinity */
69 Lisp_Object Vprint_length
;
71 /* Maximum depth of list to print in full; noninteger means
72 effectively infinity. */
74 Lisp_Object Vprint_level
;
76 /* Nonzero means print newlines in strings as \n. */
78 int print_escape_newlines
;
80 Lisp_Object Qprint_escape_newlines
;
82 /* Nonzero means print (quote foo) forms as 'foo, etc. */
86 /* Non-nil means print #: before uninterned symbols.
87 Neither t nor nil means so that and don't clear Vprint_gensym_alist
88 on entry to and exit from print functions. */
90 Lisp_Object Vprint_gensym
;
92 /* Association list of certain objects that are `eq' in the form being
93 printed and which should be `eq' when read back in, using the #n=object
94 and #n# reader forms. Each element has the form (object . n). */
96 Lisp_Object Vprint_gensym_alist
;
98 /* Nonzero means print newline to stdout before next minibuffer message.
101 extern int noninteractive_need_newline
;
103 extern int minibuffer_auto_raise
;
105 #ifdef MAX_PRINT_CHARS
106 static int print_chars
;
107 static int max_print
;
108 #endif /* MAX_PRINT_CHARS */
110 void print_interval ();
113 /* Convert between chars and GLYPHs */
117 register GLYPH
*glyphs
;
127 str_to_glyph_cpy (str
, glyphs
)
131 register GLYPH
*gp
= glyphs
;
132 register char *cp
= str
;
139 str_to_glyph_ncpy (str
, glyphs
, n
)
144 register GLYPH
*gp
= glyphs
;
145 register char *cp
= str
;
152 glyph_to_str_cpy (glyphs
, str
)
156 register GLYPH
*gp
= glyphs
;
157 register char *cp
= str
;
160 *str
++ = *gp
++ & 0377;
164 /* Low level output routines for characters and strings */
166 /* Lisp functions to do output using a stream
167 must have the stream in a variable called printcharfun
168 and must start with PRINTPREPARE, end with PRINTFINISH,
169 and use PRINTDECLARE to declare common variables.
170 Use PRINTCHAR to output one character,
171 or call strout to output a block of characters.
174 #define PRINTDECLARE \
175 struct buffer *old = current_buffer; \
176 int old_point = -1, start_point; \
177 int specpdl_count = specpdl_ptr - specpdl; \
178 int free_print_buffer = 0; \
181 #define PRINTPREPARE \
182 original = printcharfun; \
183 if (NILP (printcharfun)) printcharfun = Qt; \
184 if (BUFFERP (printcharfun)) \
186 if (XBUFFER (printcharfun) != current_buffer) \
187 Fset_buffer (printcharfun); \
188 printcharfun = Qnil; \
190 if (MARKERP (printcharfun)) \
192 if (!(XMARKER (original)->buffer)) \
193 error ("Marker does not point anywhere"); \
194 if (XMARKER (original)->buffer != current_buffer) \
195 set_buffer_internal (XMARKER (original)->buffer); \
197 SET_PT (marker_position (printcharfun)); \
199 printcharfun = Qnil; \
201 if (NILP (printcharfun)) \
203 if (print_buffer != 0) \
204 record_unwind_protect (print_unwind, \
205 make_string (print_buffer, \
206 print_buffer_pos)); \
209 print_buffer_size = 1000; \
210 print_buffer = (char *) xmalloc (print_buffer_size); \
211 free_print_buffer = 1; \
213 print_buffer_pos = 0; \
215 if (!CONSP (Vprint_gensym)) \
216 Vprint_gensym_alist = Qnil
218 #define PRINTFINISH \
219 if (NILP (printcharfun)) \
220 insert (print_buffer, print_buffer_pos); \
221 if (free_print_buffer) \
223 xfree (print_buffer); \
226 unbind_to (specpdl_count, Qnil); \
227 if (MARKERP (original)) \
228 Fset_marker (original, make_number (PT), Qnil); \
229 if (old_point >= 0) \
230 SET_PT (old_point + (old_point >= start_point \
231 ? PT - start_point : 0)); \
232 if (old != current_buffer) \
233 set_buffer_internal (old); \
234 if (!CONSP (Vprint_gensym)) \
235 Vprint_gensym_alist = Qnil
237 #define PRINTCHAR(ch) printchar (ch, printcharfun)
239 /* Nonzero if there is no room to print any more characters
240 so print might as well return right away. */
242 #define PRINTFULLP() \
243 (EQ (printcharfun, Qt) && !noninteractive \
244 && printbufidx >= FRAME_WIDTH (XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window)))))
246 /* This is used to restore the saved contents of print_buffer
247 when there is a recursive call to print. */
249 print_unwind (saved_text
)
250 Lisp_Object saved_text
;
252 bcopy (XSTRING (saved_text
)->data
, print_buffer
, XSTRING (saved_text
)->size
);
255 /* Index of first unused element of FRAME_MESSAGE_BUF (mini_frame). */
256 static int printbufidx
;
265 #ifdef MAX_PRINT_CHARS
268 #endif /* MAX_PRINT_CHARS */
276 len
= CHAR_STRING (ch
, work
, str
);
277 if (print_buffer_pos
+ len
>= print_buffer_size
)
278 print_buffer
= (char *) xrealloc (print_buffer
,
279 print_buffer_size
*= 2);
280 bcopy (str
, print_buffer
+ print_buffer_pos
, len
);
281 print_buffer_pos
+= len
;
288 = XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window
)));
289 unsigned char work
[4], *str
;
290 int len
= CHAR_STRING (ch
, work
, str
);
297 putchar (*str
), str
++;
298 noninteractive_need_newline
= 1;
302 if (echo_area_glyphs
!= FRAME_MESSAGE_BUF (mini_frame
)
303 || !message_buf_print
)
305 message_log_maybe_newline ();
306 echo_area_glyphs
= FRAME_MESSAGE_BUF (mini_frame
);
308 echo_area_glyphs_length
= 0;
309 message_buf_print
= 1;
311 if (minibuffer_auto_raise
)
313 Lisp_Object mini_window
;
315 /* Get the frame containing the minibuffer
316 that the selected frame is using. */
317 mini_window
= FRAME_MINIBUF_WINDOW (selected_frame
);
319 Fraise_frame (WINDOW_FRAME (XWINDOW (mini_window
)));
323 message_dolog (str
, len
, 0);
324 if (printbufidx
< FRAME_MESSAGE_BUF_SIZE (mini_frame
) - len
)
325 bcopy (str
, &FRAME_MESSAGE_BUF (mini_frame
)[printbufidx
], len
),
327 FRAME_MESSAGE_BUF (mini_frame
)[printbufidx
] = 0;
328 echo_area_glyphs_length
= printbufidx
;
332 #endif /* not standalone */
334 XSETFASTINT (ch1
, ch
);
339 strout (ptr
, size
, printcharfun
)
342 Lisp_Object printcharfun
;
349 if (EQ (printcharfun
, Qnil
))
351 if (print_buffer_pos
+ size
> print_buffer_size
)
353 print_buffer_size
= print_buffer_size
* 2 + size
;
354 print_buffer
= (char *) xrealloc (print_buffer
,
357 bcopy (ptr
, print_buffer
+ print_buffer_pos
, size
);
358 print_buffer_pos
+= size
;
360 #ifdef MAX_PRINT_CHARS
363 #endif /* MAX_PRINT_CHARS */
366 if (EQ (printcharfun
, Qt
))
369 = XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window
)));
373 #ifdef MAX_PRINT_CHARS
376 #endif /* MAX_PRINT_CHARS */
380 fwrite (ptr
, 1, size
, stdout
);
381 noninteractive_need_newline
= 1;
385 if (echo_area_glyphs
!= FRAME_MESSAGE_BUF (mini_frame
)
386 || !message_buf_print
)
388 message_log_maybe_newline ();
389 echo_area_glyphs
= FRAME_MESSAGE_BUF (mini_frame
);
391 echo_area_glyphs_length
= 0;
392 message_buf_print
= 1;
394 if (minibuffer_auto_raise
)
396 Lisp_Object mini_window
;
398 /* Get the frame containing the minibuffer
399 that the selected frame is using. */
400 mini_window
= FRAME_MINIBUF_WINDOW (selected_frame
);
402 Fraise_frame (WINDOW_FRAME (XWINDOW (mini_window
)));
406 message_dolog (ptr
, size
, 0);
407 if (size
> FRAME_MESSAGE_BUF_SIZE (mini_frame
) - printbufidx
- 1)
409 size
= FRAME_MESSAGE_BUF_SIZE (mini_frame
) - printbufidx
- 1;
410 /* Rewind incomplete multi-byte form. */
411 while (size
&& (unsigned char) ptr
[size
] >= 0xA0) size
--;
413 bcopy (ptr
, &FRAME_MESSAGE_BUF (mini_frame
) [printbufidx
], size
);
415 echo_area_glyphs_length
= printbufidx
;
416 FRAME_MESSAGE_BUF (mini_frame
) [printbufidx
] = 0;
424 /* Here, we must convert each multi-byte form to the
425 corresponding character code before handing it to PRINTCHAR. */
427 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size
- i
, len
);
434 /* Print the contents of a string STRING using PRINTCHARFUN.
435 It isn't safe to use strout in many cases,
436 because printing one char can relocate. */
438 print_string (string
, printcharfun
)
440 Lisp_Object printcharfun
;
442 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
443 /* strout is safe for output to a frame (echo area) or to print_buffer. */
444 strout (XSTRING (string
)->data
, XSTRING (string
)->size
, printcharfun
);
447 /* Otherwise, fetch the string address for each character. */
449 int size
= XSTRING (string
)->size
;
452 for (i
= 0; i
< size
; i
++)
453 PRINTCHAR (XSTRING (string
)->data
[i
]);
458 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
459 "Output character CHARACTER to stream PRINTCHARFUN.\n\
460 PRINTCHARFUN defaults to the value of `standard-output' (which see).")
461 (character
, printcharfun
)
462 Lisp_Object character
, printcharfun
;
466 if (NILP (printcharfun
))
467 printcharfun
= Vstandard_output
;
468 CHECK_NUMBER (character
, 0);
470 PRINTCHAR (XINT (character
));
475 /* Used from outside of print.c to print a block of SIZE chars at DATA
476 on the default output stream.
477 Do not use this on the contents of a Lisp string. */
479 write_string (data
, size
)
484 Lisp_Object printcharfun
;
486 printcharfun
= Vstandard_output
;
489 strout (data
, size
, printcharfun
);
493 /* Used from outside of print.c to print a block of SIZE chars at DATA
494 on a specified stream PRINTCHARFUN.
495 Do not use this on the contents of a Lisp string. */
497 write_string_1 (data
, size
, printcharfun
)
500 Lisp_Object printcharfun
;
505 strout (data
, size
, printcharfun
);
513 temp_output_buffer_setup (bufname
)
516 register struct buffer
*old
= current_buffer
;
517 register Lisp_Object buf
;
519 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
521 current_buffer
->directory
= old
->directory
;
522 current_buffer
->read_only
= Qnil
;
525 XSETBUFFER (buf
, current_buffer
);
526 specbind (Qstandard_output
, buf
);
528 set_buffer_internal (old
);
532 internal_with_output_to_temp_buffer (bufname
, function
, args
)
534 Lisp_Object (*function
) ();
537 int count
= specpdl_ptr
- specpdl
;
538 Lisp_Object buf
, val
;
542 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
543 temp_output_buffer_setup (bufname
);
544 buf
= Vstandard_output
;
547 val
= (*function
) (args
);
550 temp_output_buffer_show (buf
);
553 return unbind_to (count
, val
);
556 DEFUN ("with-output-to-temp-buffer", Fwith_output_to_temp_buffer
, Swith_output_to_temp_buffer
,
558 "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.\n\
559 The buffer is cleared out initially, and marked as unmodified when done.\n\
560 All output done by BODY is inserted in that buffer by default.\n\
561 The buffer is displayed in another window, but not selected.\n\
562 The value of the last form in BODY is returned.\n\
563 If BODY does not finish normally, the buffer BUFNAME is not displayed.\n\n\
564 If variable `temp-buffer-show-function' is non-nil, call it at the end\n\
565 to get the buffer displayed. It gets one argument, the buffer to display.")
571 int count
= specpdl_ptr
- specpdl
;
572 Lisp_Object buf
, val
;
575 name
= Feval (Fcar (args
));
578 CHECK_STRING (name
, 0);
579 temp_output_buffer_setup (XSTRING (name
)->data
);
580 buf
= Vstandard_output
;
582 val
= Fprogn (Fcdr (args
));
584 temp_output_buffer_show (buf
);
586 return unbind_to (count
, val
);
588 #endif /* not standalone */
590 static void print ();
592 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
593 "Output a newline to stream PRINTCHARFUN.\n\
594 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used.")
596 Lisp_Object printcharfun
;
600 if (NILP (printcharfun
))
601 printcharfun
= Vstandard_output
;
608 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
609 "Output the printed representation of OBJECT, any Lisp object.\n\
610 Quoting characters are printed when needed to make output that `read'\n\
611 can handle, whenever this is possible.\n\
612 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
613 (object
, printcharfun
)
614 Lisp_Object object
, printcharfun
;
618 #ifdef MAX_PRINT_CHARS
620 #endif /* MAX_PRINT_CHARS */
621 if (NILP (printcharfun
))
622 printcharfun
= Vstandard_output
;
625 print (object
, printcharfun
, 1);
630 /* a buffer which is used to hold output being built by prin1-to-string */
631 Lisp_Object Vprin1_to_string_buffer
;
633 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
634 "Return a string containing the printed representation of OBJECT,\n\
635 any Lisp object. Quoting characters are used when needed to make output\n\
636 that `read' can handle, whenever this is possible, unless the optional\n\
637 second argument NOESCAPE is non-nil.")
639 Lisp_Object object
, noescape
;
642 Lisp_Object printcharfun
;
643 struct gcpro gcpro1
, gcpro2
;
646 /* Save and restore this--we are altering a buffer
647 but we don't want to deactivate the mark just for that.
648 No need for specbind, since errors deactivate the mark. */
649 tem
= Vdeactivate_mark
;
650 GCPRO2 (object
, tem
);
652 printcharfun
= Vprin1_to_string_buffer
;
655 print (object
, printcharfun
, NILP (noescape
));
656 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
658 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
659 object
= Fbuffer_string ();
662 set_buffer_internal (old
);
664 Vdeactivate_mark
= tem
;
670 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
671 "Output the printed representation of OBJECT, any Lisp object.\n\
672 No quoting characters are used; no delimiters are printed around\n\
673 the contents of strings.\n\
674 Output stream is PRINTCHARFUN, or value of standard-output (which see).")
675 (object
, printcharfun
)
676 Lisp_Object object
, printcharfun
;
680 if (NILP (printcharfun
))
681 printcharfun
= Vstandard_output
;
684 print (object
, printcharfun
, 0);
689 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
690 "Output the printed representation of OBJECT, with newlines around it.\n\
691 Quoting characters are printed when needed to make output that `read'\n\
692 can handle, whenever this is possible.\n\
693 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
694 (object
, printcharfun
)
695 Lisp_Object object
, printcharfun
;
700 #ifdef MAX_PRINT_CHARS
702 max_print
= MAX_PRINT_CHARS
;
703 #endif /* MAX_PRINT_CHARS */
704 if (NILP (printcharfun
))
705 printcharfun
= Vstandard_output
;
710 print (object
, printcharfun
, 1);
713 #ifdef MAX_PRINT_CHARS
716 #endif /* MAX_PRINT_CHARS */
721 /* The subroutine object for external-debugging-output is kept here
722 for the convenience of the debugger. */
723 Lisp_Object Qexternal_debugging_output
;
725 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
726 "Write CHARACTER to stderr.\n\
727 You can call print while debugging emacs, and pass it this function\n\
728 to make it write to the debugging output.\n")
730 Lisp_Object character
;
732 CHECK_NUMBER (character
, 0);
733 putc (XINT (character
), stderr
);
736 /* Send the output to a debugger (nothing happens if there isn't one). */
738 char buf
[2] = {(char) XINT (character
), '\0'};
739 OutputDebugString (buf
);
746 /* This is the interface for debugging printing. */
752 Fprin1 (arg
, Qexternal_debugging_output
);
753 fprintf (stderr
, "\r\n");
756 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
758 "Convert an error value (ERROR-SYMBOL . DATA) to an error message.")
762 struct buffer
*old
= current_buffer
;
763 Lisp_Object original
, printcharfun
, value
;
766 /* If OBJ is (error STRING), just return STRING.
767 That is not only faster, it also avoids the need to allocate
768 space here when the error is due to memory full. */
769 if (CONSP (obj
) && EQ (XCONS (obj
)->car
, Qerror
)
770 && CONSP (XCONS (obj
)->cdr
)
771 && STRINGP (XCONS (XCONS (obj
)->cdr
)->car
)
772 && NILP (XCONS (XCONS (obj
)->cdr
)->cdr
))
773 return XCONS (XCONS (obj
)->cdr
)->car
;
775 print_error_message (obj
, Vprin1_to_string_buffer
, NULL
);
777 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
778 value
= Fbuffer_string ();
782 set_buffer_internal (old
);
788 /* Print an error message for the error DATA
789 onto Lisp output stream STREAM (suitable for the print functions). */
791 print_error_message (data
, stream
)
792 Lisp_Object data
, stream
;
794 Lisp_Object errname
, errmsg
, file_error
, tail
;
798 errname
= Fcar (data
);
800 if (EQ (errname
, Qerror
))
803 if (!CONSP (data
)) data
= Qnil
;
804 errmsg
= Fcar (data
);
809 errmsg
= Fget (errname
, Qerror_message
);
810 file_error
= Fmemq (Qfile_error
,
811 Fget (errname
, Qerror_conditions
));
814 /* Print an error message including the data items. */
816 tail
= Fcdr_safe (data
);
819 /* For file-error, make error message by concatenating
820 all the data items. They are all strings. */
821 if (!NILP (file_error
) && !NILP (tail
))
822 errmsg
= XCONS (tail
)->car
, tail
= XCONS (tail
)->cdr
;
824 if (STRINGP (errmsg
))
825 Fprinc (errmsg
, stream
);
827 write_string_1 ("peculiar error", -1, stream
);
829 for (i
= 0; CONSP (tail
); tail
= Fcdr (tail
), i
++)
831 write_string_1 (i
? ", " : ": ", 2, stream
);
832 if (!NILP (file_error
))
833 Fprinc (Fcar (tail
), stream
);
835 Fprin1 (Fcar (tail
), stream
);
840 #ifdef LISP_FLOAT_TYPE
843 * The buffer should be at least as large as the max string size of the
844 * largest float, printed in the biggest notation. This is undoubtedly
845 * 20d float_output_format, with the negative of the C-constant "HUGE"
848 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
850 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
851 * case of -1e307 in 20d float_output_format. What is one to do (short of
852 * re-writing _doprnt to be more sane)?
857 float_to_string (buf
, data
)
864 if (NILP (Vfloat_output_format
)
865 || !STRINGP (Vfloat_output_format
))
868 sprintf (buf
, "%.17g", data
);
873 /* Check that the spec we have is fully valid.
874 This means not only valid for printf,
875 but meant for floats, and reasonable. */
876 cp
= XSTRING (Vfloat_output_format
)->data
;
885 /* Check the width specification. */
887 if ('0' <= *cp
&& *cp
<= '9')
891 width
= (width
* 10) + (*cp
++ - '0');
892 while (*cp
>= '0' && *cp
<= '9');
894 /* A precision of zero is valid only for %f. */
896 || (width
== 0 && *cp
!= 'f'))
900 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
906 sprintf (buf
, XSTRING (Vfloat_output_format
)->data
, data
);
909 /* Make sure there is a decimal point with digit after, or an
910 exponent, so that the value is readable as a float. But don't do
911 this with "%.0f"; it's valid for that not to produce a decimal
912 point. Note that width can be 0 only for %.0f. */
915 for (cp
= buf
; *cp
; cp
++)
916 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
919 if (*cp
== '.' && cp
[1] == 0)
933 #endif /* LISP_FLOAT_TYPE */
936 print (obj
, printcharfun
, escapeflag
)
938 register Lisp_Object printcharfun
;
945 #if 1 /* I'm not sure this is really worth doing. */
946 /* Detect circularities and truncate them.
947 No need to offer any alternative--this is better than an error. */
948 if (CONSP (obj
) || VECTORP (obj
) || COMPILEDP (obj
))
951 for (i
= 0; i
< print_depth
; i
++)
952 if (EQ (obj
, being_printed
[i
]))
954 sprintf (buf
, "#%d", i
);
955 strout (buf
, -1, printcharfun
);
961 being_printed
[print_depth
] = obj
;
964 if (print_depth
> PRINT_CIRCLE
)
965 error ("Apparently circular structure being printed");
966 #ifdef MAX_PRINT_CHARS
967 if (max_print
&& print_chars
> max_print
)
972 #endif /* MAX_PRINT_CHARS */
974 switch (XGCTYPE (obj
))
977 if (sizeof (int) == sizeof (EMACS_INT
))
978 sprintf (buf
, "%d", XINT (obj
));
979 else if (sizeof (long) == sizeof (EMACS_INT
))
980 sprintf (buf
, "%ld", XINT (obj
));
983 strout (buf
, -1, printcharfun
);
986 #ifdef LISP_FLOAT_TYPE
989 char pigbuf
[350]; /* see comments in float_to_string */
991 float_to_string (pigbuf
, XFLOAT(obj
)->data
);
992 strout (pigbuf
, -1, printcharfun
);
999 print_string (obj
, printcharfun
);
1003 register unsigned char c
;
1004 struct gcpro gcpro1
;
1008 #ifdef USE_TEXT_PROPERTIES
1009 if (!NULL_INTERVAL_P (XSTRING (obj
)->intervals
))
1017 for (i
= 0; i
< XSTRING (obj
)->size
; i
++)
1020 c
= XSTRING (obj
)->data
[i
];
1021 if (c
== '\n' && print_escape_newlines
)
1026 else if (c
== '\f' && print_escape_newlines
)
1033 if (c
== '\"' || c
== '\\')
1040 #ifdef USE_TEXT_PROPERTIES
1041 if (!NULL_INTERVAL_P (XSTRING (obj
)->intervals
))
1043 traverse_intervals (XSTRING (obj
)->intervals
,
1044 0, 0, print_interval
, printcharfun
);
1055 register int confusing
;
1056 register unsigned char *p
= XSYMBOL (obj
)->name
->data
;
1057 register unsigned char *end
= p
+ XSYMBOL (obj
)->name
->size
;
1058 register unsigned char c
;
1061 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1064 /* If symbol name begins with a digit, and ends with a digit,
1065 and contains nothing but digits and `e', it could be treated
1066 as a number. So set CONFUSING.
1068 Symbols that contain periods could also be taken as numbers,
1069 but periods are always escaped, so we don't have to worry
1071 else if (*p
>= '0' && *p
<= '9'
1072 && end
[-1] >= '0' && end
[-1] <= '9')
1074 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1075 /* Needed for \2e10. */
1078 confusing
= (end
== p
);
1083 /* If we print an uninterned symbol as part of a complex object and
1084 the flag print-gensym is non-nil, prefix it with #n= to read the
1085 object back with the #n# reader syntax later if needed. */
1086 if (! NILP (Vprint_gensym
) && NILP (XSYMBOL (obj
)->obarray
))
1088 if (print_depth
> 1)
1091 tem
= Fassq (obj
, Vprint_gensym_alist
);
1095 print (XCDR (tem
), printcharfun
, escapeflag
);
1101 if (CONSP (Vprint_gensym_alist
))
1102 XSETFASTINT (tem
, XFASTINT (XCDR (XCAR (Vprint_gensym_alist
))) + 1);
1104 XSETFASTINT (tem
, 1);
1105 Vprint_gensym_alist
= Fcons (Fcons (obj
, tem
), Vprint_gensym_alist
);
1108 print (tem
, printcharfun
, escapeflag
);
1116 for (i
= 0; i
< XSYMBOL (obj
)->name
->size
; i
++)
1119 c
= XSYMBOL (obj
)->name
->data
[i
];
1123 if (c
== '\"' || c
== '\\' || c
== '\''
1124 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1125 || c
== ',' || c
=='.' || c
== '`'
1126 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1128 PRINTCHAR ('\\'), confusing
= 0;
1136 /* If deeper than spec'd depth, print placeholder. */
1137 if (INTEGERP (Vprint_level
)
1138 && print_depth
> XINT (Vprint_level
))
1139 strout ("...", -1, printcharfun
);
1140 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1141 && (EQ (XCAR (obj
), Qquote
)))
1144 print (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1146 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1147 && (EQ (XCAR (obj
), Qfunction
)))
1151 print (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1153 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1154 && ((EQ (XCAR (obj
), Qbackquote
)
1155 || EQ (XCAR (obj
), Qcomma
)
1156 || EQ (XCAR (obj
), Qcomma_at
)
1157 || EQ (XCAR (obj
), Qcomma_dot
))))
1159 print (XCAR (obj
), printcharfun
, 0);
1160 print (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1167 register int max
= 0;
1169 if (INTEGERP (Vprint_length
))
1170 max
= XINT (Vprint_length
);
1171 /* Could recognize circularities in cdrs here,
1172 but that would make printing of long lists quadratic.
1173 It's not worth doing. */
1180 strout ("...", 3, printcharfun
);
1183 print (XCAR (obj
), printcharfun
, escapeflag
);
1189 strout (" . ", 3, printcharfun
);
1190 print (obj
, printcharfun
, escapeflag
);
1196 case Lisp_Vectorlike
:
1201 strout ("#<process ", -1, printcharfun
);
1202 print_string (XPROCESS (obj
)->name
, printcharfun
);
1206 print_string (XPROCESS (obj
)->name
, printcharfun
);
1208 else if (BOOL_VECTOR_P (obj
))
1211 register unsigned char c
;
1212 struct gcpro gcpro1
;
1214 = (XBOOL_VECTOR (obj
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1220 sprintf (buf
, "%d", XBOOL_VECTOR (obj
)->size
);
1221 strout (buf
, -1, printcharfun
);
1224 /* Don't print more characters than the specified maximum. */
1225 if (INTEGERP (Vprint_length
)
1226 && XINT (Vprint_length
) < size_in_chars
)
1227 size_in_chars
= XINT (Vprint_length
);
1229 for (i
= 0; i
< size_in_chars
; i
++)
1232 c
= XBOOL_VECTOR (obj
)->data
[i
];
1233 if (c
== '\n' && print_escape_newlines
)
1238 else if (c
== '\f' && print_escape_newlines
)
1245 if (c
== '\"' || c
== '\\')
1254 else if (SUBRP (obj
))
1256 strout ("#<subr ", -1, printcharfun
);
1257 strout (XSUBR (obj
)->symbol_name
, -1, printcharfun
);
1261 else if (WINDOWP (obj
))
1263 strout ("#<window ", -1, printcharfun
);
1264 sprintf (buf
, "%d", XFASTINT (XWINDOW (obj
)->sequence_number
));
1265 strout (buf
, -1, printcharfun
);
1266 if (!NILP (XWINDOW (obj
)->buffer
))
1268 strout (" on ", -1, printcharfun
);
1269 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1273 else if (BUFFERP (obj
))
1275 if (NILP (XBUFFER (obj
)->name
))
1276 strout ("#<killed buffer>", -1, printcharfun
);
1277 else if (escapeflag
)
1279 strout ("#<buffer ", -1, printcharfun
);
1280 print_string (XBUFFER (obj
)->name
, printcharfun
);
1284 print_string (XBUFFER (obj
)->name
, printcharfun
);
1286 else if (WINDOW_CONFIGURATIONP (obj
))
1288 strout ("#<window-configuration>", -1, printcharfun
);
1290 else if (FRAMEP (obj
))
1292 strout ((FRAME_LIVE_P (XFRAME (obj
))
1293 ? "#<frame " : "#<dead frame "),
1295 print_string (XFRAME (obj
)->name
, printcharfun
);
1296 sprintf (buf
, " 0x%lx", (unsigned long) (XFRAME (obj
)));
1297 strout (buf
, -1, printcharfun
);
1300 #endif /* not standalone */
1303 int size
= XVECTOR (obj
)->size
;
1304 if (COMPILEDP (obj
))
1307 size
&= PSEUDOVECTOR_SIZE_MASK
;
1309 if (CHAR_TABLE_P (obj
))
1311 /* We print a char-table as if it were a vector,
1312 lumping the parent and default slots in with the
1313 character slots. But we add #^ as a prefix. */
1316 if (SUB_CHAR_TABLE_P (obj
))
1318 size
&= PSEUDOVECTOR_SIZE_MASK
;
1320 if (size
& PSEUDOVECTOR_FLAG
)
1326 register Lisp_Object tem
;
1328 /* Don't print more elements than the specified maximum. */
1329 if (INTEGERP (Vprint_length
)
1330 && XINT (Vprint_length
) < size
)
1331 size
= XINT (Vprint_length
);
1333 for (i
= 0; i
< size
; i
++)
1335 if (i
) PRINTCHAR (' ');
1336 tem
= XVECTOR (obj
)->contents
[i
];
1337 print (tem
, printcharfun
, escapeflag
);
1346 switch (XMISCTYPE (obj
))
1348 case Lisp_Misc_Marker
:
1349 strout ("#<marker ", -1, printcharfun
);
1351 /* Do you think this is necessary? */
1352 if (XMARKER (obj
)->insertion_type
!= 0)
1353 strout ("(before-insertion) ", -1, printcharfun
);
1355 if (!(XMARKER (obj
)->buffer
))
1356 strout ("in no buffer", -1, printcharfun
);
1359 sprintf (buf
, "at %d", marker_position (obj
));
1360 strout (buf
, -1, printcharfun
);
1361 strout (" in ", -1, printcharfun
);
1362 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
1367 case Lisp_Misc_Overlay
:
1368 strout ("#<overlay ", -1, printcharfun
);
1369 if (!(XMARKER (OVERLAY_START (obj
))->buffer
))
1370 strout ("in no buffer", -1, printcharfun
);
1373 sprintf (buf
, "from %d to %d in ",
1374 marker_position (OVERLAY_START (obj
)),
1375 marker_position (OVERLAY_END (obj
)));
1376 strout (buf
, -1, printcharfun
);
1377 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
1383 /* Remaining cases shouldn't happen in normal usage, but let's print
1384 them anyway for the benefit of the debugger. */
1385 case Lisp_Misc_Free
:
1386 strout ("#<misc free cell>", -1, printcharfun
);
1389 case Lisp_Misc_Intfwd
:
1390 sprintf (buf
, "#<intfwd to %d>", *XINTFWD (obj
)->intvar
);
1391 strout (buf
, -1, printcharfun
);
1394 case Lisp_Misc_Boolfwd
:
1395 sprintf (buf
, "#<boolfwd to %s>",
1396 (*XBOOLFWD (obj
)->boolvar
? "t" : "nil"));
1397 strout (buf
, -1, printcharfun
);
1400 case Lisp_Misc_Objfwd
:
1401 strout ("#<objfwd to ", -1, printcharfun
);
1402 print (*XOBJFWD (obj
)->objvar
, printcharfun
, escapeflag
);
1406 case Lisp_Misc_Buffer_Objfwd
:
1407 strout ("#<buffer_objfwd to ", -1, printcharfun
);
1408 print (*(Lisp_Object
*)((char *)current_buffer
1409 + XBUFFER_OBJFWD (obj
)->offset
),
1410 printcharfun
, escapeflag
);
1414 case Lisp_Misc_Kboard_Objfwd
:
1415 strout ("#<kboard_objfwd to ", -1, printcharfun
);
1416 print (*(Lisp_Object
*)((char *) current_kboard
1417 + XKBOARD_OBJFWD (obj
)->offset
),
1418 printcharfun
, escapeflag
);
1422 case Lisp_Misc_Buffer_Local_Value
:
1423 strout ("#<buffer_local_value ", -1, printcharfun
);
1424 goto do_buffer_local
;
1425 case Lisp_Misc_Some_Buffer_Local_Value
:
1426 strout ("#<some_buffer_local_value ", -1, printcharfun
);
1428 strout ("[realvalue] ", -1, printcharfun
);
1429 print (XBUFFER_LOCAL_VALUE (obj
)->car
, printcharfun
, escapeflag
);
1430 strout ("[buffer] ", -1, printcharfun
);
1431 print (XCONS (XBUFFER_LOCAL_VALUE (obj
)->cdr
)->car
,
1432 printcharfun
, escapeflag
);
1433 strout ("[alist-elt] ", -1, printcharfun
);
1434 print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj
)->cdr
)->cdr
)->car
,
1435 printcharfun
, escapeflag
);
1436 strout ("[default-value] ", -1, printcharfun
);
1437 print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj
)->cdr
)->cdr
)->cdr
,
1438 printcharfun
, escapeflag
);
1446 #endif /* standalone */
1451 /* We're in trouble if this happens!
1452 Probably should just abort () */
1453 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, printcharfun
);
1455 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
1456 else if (VECTORLIKEP (obj
))
1457 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
1459 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
1460 strout (buf
, -1, printcharfun
);
1461 strout (" Save your buffers immediately and please report this bug>",
1469 #ifdef USE_TEXT_PROPERTIES
1471 /* Print a description of INTERVAL using PRINTCHARFUN.
1472 This is part of printing a string that has text properties. */
1475 print_interval (interval
, printcharfun
)
1477 Lisp_Object printcharfun
;
1480 print (make_number (interval
->position
), printcharfun
, 1);
1482 print (make_number (interval
->position
+ LENGTH (interval
)),
1485 print (interval
->plist
, printcharfun
, 1);
1488 #endif /* USE_TEXT_PROPERTIES */
1493 DEFVAR_LISP ("standard-output", &Vstandard_output
,
1494 "Output stream `print' uses by default for outputting a character.\n\
1495 This may be any function of one argument.\n\
1496 It may also be a buffer (output is inserted before point)\n\
1497 or a marker (output is inserted and the marker is advanced)\n\
1498 or the symbol t (output appears in the echo area).");
1499 Vstandard_output
= Qt
;
1500 Qstandard_output
= intern ("standard-output");
1501 staticpro (&Qstandard_output
);
1503 #ifdef LISP_FLOAT_TYPE
1504 DEFVAR_LISP ("float-output-format", &Vfloat_output_format
,
1505 "The format descriptor string used to print floats.\n\
1506 This is a %-spec like those accepted by `printf' in C,\n\
1507 but with some restrictions. It must start with the two characters `%.'.\n\
1508 After that comes an integer precision specification,\n\
1509 and then a letter which controls the format.\n\
1510 The letters allowed are `e', `f' and `g'.\n\
1511 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"\n\
1512 Use `f' for decimal point notation \"DIGITS.DIGITS\".\n\
1513 Use `g' to choose the shorter of those two formats for the number at hand.\n\
1514 The precision in any of these cases is the number of digits following\n\
1515 the decimal point. With `f', a precision of 0 means to omit the\n\
1516 decimal point. 0 is not allowed with `e' or `g'.\n\n\
1517 A value of nil means to use `%.17g'.");
1518 Vfloat_output_format
= Qnil
;
1519 Qfloat_output_format
= intern ("float-output-format");
1520 staticpro (&Qfloat_output_format
);
1521 #endif /* LISP_FLOAT_TYPE */
1523 DEFVAR_LISP ("print-length", &Vprint_length
,
1524 "Maximum length of list to print before abbreviating.\n\
1525 A value of nil means no limit.");
1526 Vprint_length
= Qnil
;
1528 DEFVAR_LISP ("print-level", &Vprint_level
,
1529 "Maximum depth of list nesting to print before abbreviating.\n\
1530 A value of nil means no limit.");
1531 Vprint_level
= Qnil
;
1533 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines
,
1534 "Non-nil means print newlines in strings as backslash-n.\n\
1535 Also print formfeeds as backslash-f.");
1536 print_escape_newlines
= 0;
1538 DEFVAR_BOOL ("print-quoted", &print_quoted
,
1539 "Non-nil means print quoted forms with reader syntax.\n\
1540 I.e., (quote foo) prints as 'foo, (function foo) as #'foo, and, backquoted\n\
1541 forms print in the new syntax.");
1544 DEFVAR_LISP ("print-gensym", &Vprint_gensym
,
1545 "Non-nil means print uninterned symbols so they will read as uninterned.\n\
1546 I.e., the value of (make-symbol "foobar
") prints as #:foobar.\n\
1547 When the uninterned symbol appears within a larger data structure,\n\
1548 in addition use the #...# and #...= constructs as needed,\n\
1549 so that multiple references to the same symbol are shared once again\n\
1550 when the text is read back.\n\
1552 If the value of `print-gensym' is a cons cell, then in addition refrain from\n\
1553 clearing `print-gensym-alist' on entry to and exit from printing functions,\n\
1554 so that the use of #...# and #...= can carry over for several separately\n\
1556 Vprint_gensym
= Qnil
;
1558 DEFVAR_LISP ("print-gensym-alist", &Vprint_gensym_alist
,
1559 "Association list of elements (GENSYM . N) to guide use of #N# and #N=.\n\
1560 In each element, GENSYM is an uninterned symbol that has been associated\n\
1561 with #N= for the specified value of N.");
1562 Vprint_gensym_alist
= Qnil
;
1564 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
1565 staticpro (&Vprin1_to_string_buffer
);
1568 defsubr (&Sprin1_to_string
);
1569 defsubr (&Serror_message_string
);
1573 defsubr (&Swrite_char
);
1574 defsubr (&Sexternal_debugging_output
);
1576 Qexternal_debugging_output
= intern ("external-debugging-output");
1577 staticpro (&Qexternal_debugging_output
);
1579 Qprint_escape_newlines
= intern ("print-escape-newlines");
1580 staticpro (&Qprint_escape_newlines
);
1583 defsubr (&Swith_output_to_temp_buffer
);
1584 #endif /* not standalone */