1 /* Lisp object printing and output streams.
2 Copyright (C) 1985, 1986, 1988, 1992 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, 675 Mass Ave, Cambridge, MA 02139, USA. */
31 #include "dispextern.h"
33 #endif /* not standalone */
35 Lisp_Object Vstandard_output
, Qstandard_output
;
37 #ifdef LISP_FLOAT_TYPE
38 Lisp_Object Vfloat_output_format
, Qfloat_output_format
;
39 #endif /* LISP_FLOAT_TYPE */
41 /* Avoid actual stack overflow in print. */
44 /* Detect most circularities to print finite output. */
45 #define PRINT_CIRCLE 200
46 Lisp_Object being_printed
[PRINT_CIRCLE
];
48 /* Maximum length of list to print in full; noninteger means
49 effectively infinity */
51 Lisp_Object Vprint_length
;
53 /* Maximum depth of list to print in full; noninteger means
54 effectively infinity. */
56 Lisp_Object Vprint_level
;
58 /* Nonzero means print newlines in strings as \n. */
60 int print_escape_newlines
;
62 Lisp_Object Qprint_escape_newlines
;
64 /* Nonzero means print newline before next minibuffer message.
67 extern int noninteractive_need_newline
;
68 #ifdef MAX_PRINT_CHARS
69 static int print_chars
;
71 #endif /* MAX_PRINT_CHARS */
74 /* Convert between chars and GLYPHs */
78 register GLYPH
*glyphs
;
88 str_to_glyph_cpy (str
, glyphs
)
92 register GLYPH
*gp
= glyphs
;
93 register char *cp
= str
;
100 str_to_glyph_ncpy (str
, glyphs
, n
)
105 register GLYPH
*gp
= glyphs
;
106 register char *cp
= str
;
113 glyph_to_str_cpy (glyphs
, str
)
117 register GLYPH
*gp
= glyphs
;
118 register char *cp
= str
;
121 *str
++ = *gp
++ & 0377;
125 /* Low level output routines for charaters and strings */
127 /* Lisp functions to do output using a stream
128 must have the stream in a variable called printcharfun
129 and must start with PRINTPREPARE and end with PRINTFINISH.
130 Use PRINTCHAR to output one character,
131 or call strout to output a block of characters.
132 Also, each one must have the declarations
133 struct buffer *old = current_buffer;
134 int old_point = -1, start_point;
135 Lisp_Object original;
138 #define PRINTPREPARE \
139 original = printcharfun; \
140 if (NILP (printcharfun)) printcharfun = Qt; \
141 if (XTYPE (printcharfun) == Lisp_Buffer) \
142 { if (XBUFFER (printcharfun) != current_buffer) Fset_buffer (printcharfun); \
143 printcharfun = Qnil;}\
144 if (XTYPE (printcharfun) == Lisp_Marker) \
145 { if (XMARKER (original)->buffer != current_buffer) \
146 set_buffer_internal (XMARKER (original)->buffer); \
148 SET_PT (marker_position (printcharfun)); \
149 start_point = point; \
150 printcharfun = Qnil;}
152 #define PRINTFINISH \
153 if (XTYPE (original) == Lisp_Marker) \
154 Fset_marker (original, make_number (point), Qnil); \
155 if (old_point >= 0) \
156 SET_PT ((old_point >= start_point ? point - start_point : 0) + old_point); \
157 if (old != current_buffer) \
158 set_buffer_internal (old)
160 #define PRINTCHAR(ch) printchar (ch, printcharfun)
162 /* Index of first unused element of message_buf */
163 static int printbufidx
;
172 #ifdef MAX_PRINT_CHARS
175 #endif /* MAX_PRINT_CHARS */
189 noninteractive_need_newline
= 1;
193 if (echo_area_glyphs
!= SCREEN_MESSAGE_BUF (selected_screen
)
194 || !message_buf_print
)
196 echo_area_glyphs
= SCREEN_MESSAGE_BUF (selected_screen
);
198 message_buf_print
= 1;
201 if (printbufidx
< SCREEN_WIDTH (selected_screen
) - 1)
202 SCREEN_MESSAGE_BUF (selected_screen
)[printbufidx
++] = ch
;
203 SCREEN_MESSAGE_BUF (selected_screen
)[printbufidx
] = 0;
207 #endif /* not standalone */
214 strout (ptr
, size
, printcharfun
)
217 Lisp_Object printcharfun
;
221 if (EQ (printcharfun
, Qnil
))
223 insert (ptr
, size
>= 0 ? size
: strlen (ptr
));
224 #ifdef MAX_PRINT_CHARS
226 print_chars
+= size
>= 0 ? size
: strlen(ptr
);
227 #endif /* MAX_PRINT_CHARS */
230 if (EQ (printcharfun
, Qt
))
232 i
= size
>= 0 ? size
: strlen (ptr
);
233 #ifdef MAX_PRINT_CHARS
236 #endif /* MAX_PRINT_CHARS */
240 fwrite (ptr
, 1, i
, stdout
);
241 noninteractive_need_newline
= 1;
245 if (echo_area_glyphs
!= SCREEN_MESSAGE_BUF (selected_screen
)
246 || !message_buf_print
)
248 echo_area_glyphs
= SCREEN_MESSAGE_BUF (selected_screen
);
250 message_buf_print
= 1;
253 if (i
> SCREEN_WIDTH (selected_screen
) - printbufidx
- 1)
254 i
= SCREEN_WIDTH (selected_screen
) - printbufidx
- 1;
255 bcopy (ptr
, &SCREEN_MESSAGE_BUF (selected_screen
) [printbufidx
], i
);
257 SCREEN_MESSAGE_BUF (selected_screen
) [printbufidx
] = 0;
264 PRINTCHAR (ptr
[i
++]);
267 PRINTCHAR (ptr
[i
++]);
270 /* Print the contents of a string STRING using PRINTCHARFUN.
271 It isn't safe to use strout, because printing one char can relocate. */
273 print_string (string
, printcharfun
)
275 Lisp_Object printcharfun
;
277 if (EQ (printcharfun
, Qnil
) || EQ (printcharfun
, Qt
))
278 /* In predictable cases, strout is safe: output to buffer or screen. */
279 strout (XSTRING (string
)->data
, XSTRING (string
)->size
, printcharfun
);
282 /* Otherwise, fetch the string address for each character. */
284 int size
= XSTRING (string
)->size
;
287 for (i
= 0; i
< size
; i
++)
288 PRINTCHAR (XSTRING (string
)->data
[i
]);
293 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
294 "Output character CHAR to stream STREAM.\n\
295 STREAM defaults to the value of `standard-output' (which see).")
297 Lisp_Object ch
, printcharfun
;
299 struct buffer
*old
= current_buffer
;
302 Lisp_Object original
;
304 if (NILP (printcharfun
))
305 printcharfun
= Vstandard_output
;
306 CHECK_NUMBER (ch
, 0);
308 PRINTCHAR (XINT (ch
));
313 /* Used from outside of print.c to print a block of SIZE chars at DATA
314 on the default output stream.
315 Do not use this on the contents of a Lisp string. */
317 write_string (data
, size
)
321 struct buffer
*old
= current_buffer
;
322 Lisp_Object printcharfun
;
325 Lisp_Object original
;
327 printcharfun
= Vstandard_output
;
330 strout (data
, size
, printcharfun
);
334 /* Used from outside of print.c to print a block of SIZE chars at DATA
335 on a specified stream PRINTCHARFUN.
336 Do not use this on the contents of a Lisp string. */
338 write_string_1 (data
, size
, printcharfun
)
341 Lisp_Object printcharfun
;
343 struct buffer
*old
= current_buffer
;
346 Lisp_Object original
;
349 strout (data
, size
, printcharfun
);
357 temp_output_buffer_setup (bufname
)
360 register struct buffer
*old
= current_buffer
;
361 register Lisp_Object buf
;
363 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
365 current_buffer
->read_only
= Qnil
;
368 XSET (buf
, Lisp_Buffer
, current_buffer
);
369 specbind (Qstandard_output
, buf
);
371 set_buffer_internal (old
);
375 internal_with_output_to_temp_buffer (bufname
, function
, args
)
377 Lisp_Object (*function
) ();
380 int count
= specpdl_ptr
- specpdl
;
381 Lisp_Object buf
, val
;
383 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
384 temp_output_buffer_setup (bufname
);
385 buf
= Vstandard_output
;
387 val
= (*function
) (args
);
389 temp_output_buffer_show (buf
);
391 return unbind_to (count
, val
);
394 DEFUN ("with-output-to-temp-buffer", Fwith_output_to_temp_buffer
, Swith_output_to_temp_buffer
,
396 "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.\n\
397 The buffer is cleared out initially, and marked as unmodified when done.\n\
398 All output done by BODY is inserted in that buffer by default.\n\
399 The buffer is displayed in another window, but not selected.\n\
400 The value of the last form in BODY is returned.\n\
401 If BODY does not finish normally, the buffer BUFNAME is not displayed.\n\n\
402 If variable `temp-buffer-show-hook' is non-nil, call it at the end\n\
403 to get the buffer displayed. It gets one argument, the buffer to display.")
409 int count
= specpdl_ptr
- specpdl
;
410 Lisp_Object buf
, val
;
413 name
= Feval (Fcar (args
));
416 CHECK_STRING (name
, 0);
417 temp_output_buffer_setup (XSTRING (name
)->data
);
418 buf
= Vstandard_output
;
420 val
= Fprogn (Fcdr (args
));
422 temp_output_buffer_show (buf
);
424 return unbind_to (count
, val
);
426 #endif /* not standalone */
428 static void print ();
430 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
431 "Output a newline to STREAM.\n\
432 If STREAM is omitted or nil, the value of `standard-output' is used.")
434 Lisp_Object printcharfun
;
436 struct buffer
*old
= current_buffer
;
439 Lisp_Object original
;
441 if (NILP (printcharfun
))
442 printcharfun
= Vstandard_output
;
449 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
450 "Output the printed representation of OBJECT, any Lisp object.\n\
451 Quoting characters are printed when needed to make output that `read'\n\
452 can handle, whenever this is possible.\n\
453 Output stream is STREAM, or value of `standard-output' (which see).")
455 Lisp_Object obj
, printcharfun
;
457 struct buffer
*old
= current_buffer
;
460 Lisp_Object original
;
462 #ifdef MAX_PRINT_CHARS
464 #endif /* MAX_PRINT_CHARS */
465 if (NILP (printcharfun
))
466 printcharfun
= Vstandard_output
;
469 print (obj
, printcharfun
, 1);
474 /* a buffer which is used to hold output being built by prin1-to-string */
475 Lisp_Object Vprin1_to_string_buffer
;
477 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
478 "Return a string containing the printed representation of OBJECT,\n\
479 any Lisp object. Quoting characters are used when needed to make output\n\
480 that `read' can handle, whenever this is possible, unless the optional\n\
481 second argument NOESCAPE is non-nil.")
483 Lisp_Object obj
, noescape
;
485 struct buffer
*old
= current_buffer
;
488 Lisp_Object original
, printcharfun
;
491 printcharfun
= Vprin1_to_string_buffer
;
494 print (obj
, printcharfun
, NILP (noescape
));
495 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
497 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
498 obj
= Fbuffer_string ();
502 set_buffer_internal (old
);
508 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
509 "Output the printed representation of OBJECT, any Lisp object.\n\
510 No quoting characters are used; no delimiters are printed around\n\
511 the contents of strings.\n\
512 Output stream is STREAM, or value of standard-output (which see).")
514 Lisp_Object obj
, printcharfun
;
516 struct buffer
*old
= current_buffer
;
519 Lisp_Object original
;
521 if (NILP (printcharfun
))
522 printcharfun
= Vstandard_output
;
525 print (obj
, printcharfun
, 0);
530 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
531 "Output the printed representation of OBJECT, with newlines around it.\n\
532 Quoting characters are printed when needed to make output that `read'\n\
533 can handle, whenever this is possible.\n\
534 Output stream is STREAM, or value of `standard-output' (which see).")
536 Lisp_Object obj
, printcharfun
;
538 struct buffer
*old
= current_buffer
;
541 Lisp_Object original
;
544 #ifdef MAX_PRINT_CHARS
546 max_print
= MAX_PRINT_CHARS
;
547 #endif /* MAX_PRINT_CHARS */
548 if (NILP (printcharfun
))
549 printcharfun
= Vstandard_output
;
554 print (obj
, printcharfun
, 1);
557 #ifdef MAX_PRINT_CHARS
560 #endif /* MAX_PRINT_CHARS */
565 /* The subroutine object for external-debugging-output is kept here
566 for the convenience of the debugger. */
567 Lisp_Object Qexternal_debugging_output
;
569 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
570 "Write CHARACTER to stderr.\n\
571 You can call print while debugging emacs, and pass it this function\n\
572 to make it write to the debugging output.\n")
574 Lisp_Object character
;
576 CHECK_NUMBER (character
, 0);
577 putc (XINT (character
), stderr
);
582 #ifdef LISP_FLOAT_TYPE
585 float_to_string (buf
, data
)
588 * This buffer should be at least as large as the max string size of the
589 * largest float, printed in the biggest notation. This is undoubtably
590 * 20d float_output_format, with the negative of the C-constant "HUGE"
593 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
595 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
596 * case of -1e307 in 20d float_output_format. What is one to do (short of
597 * re-writing _doprnt to be more sane)?
602 register unsigned char *cp
, c
;
605 if (NILP (Vfloat_output_format
)
606 || XTYPE (Vfloat_output_format
) != Lisp_String
)
608 sprintf (buf
, "%.20g", data
);
611 /* Check that the spec we have is fully valid.
612 This means not only valid for printf,
613 but meant for floats, and reasonable. */
614 cp
= XSTRING (Vfloat_output_format
)->data
;
623 ((c
= *cp
) >= '0' && c
<= '9');
630 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
633 if (width
< (*cp
!= 'e') || width
> DBL_DIG
)
639 sprintf (buf
, XSTRING (Vfloat_output_format
)->data
, data
);
642 #endif /* LISP_FLOAT_TYPE */
645 print (obj
, printcharfun
, escapeflag
)
646 #ifndef RTPC_REGISTER_BUG
647 register Lisp_Object obj
;
651 register Lisp_Object printcharfun
;
658 #if 1 /* I'm not sure this is really worth doing. */
659 /* Detect circularities and truncate them.
660 No need to offer any alternative--this is better than an error. */
661 if (XTYPE (obj
) == Lisp_Cons
|| XTYPE (obj
) == Lisp_Vector
662 || XTYPE (obj
) == Lisp_Compiled
)
665 for (i
= 0; i
< print_depth
; i
++)
666 if (EQ (obj
, being_printed
[i
]))
668 sprintf (buf
, "#%d", i
);
669 strout (buf
, -1, printcharfun
);
675 being_printed
[print_depth
] = obj
;
678 if (print_depth
> PRINT_CIRCLE
)
679 error ("Apparently circular structure being printed");
680 #ifdef MAX_PRINT_CHARS
681 if (max_print
&& print_chars
> max_print
)
686 #endif /* MAX_PRINT_CHARS */
688 #ifdef SWITCH_ENUM_BUG
689 switch ((int) XTYPE (obj
))
695 /* We're in trouble if this happens!
696 Probably should just abort () */
697 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, printcharfun
);
698 sprintf (buf
, "(#o%3o)", (int) XTYPE (obj
));
699 strout (buf
, -1, printcharfun
);
700 strout (" Save your buffers immediately and please report this bug>",
704 #ifdef LISP_FLOAT_TYPE
707 char pigbuf
[350]; /* see comments in float_to_string */
709 float_to_string (pigbuf
, XFLOAT(obj
)->data
);
710 strout (pigbuf
, -1, printcharfun
);
713 #endif /* LISP_FLOAT_TYPE */
716 sprintf (buf
, "%d", XINT (obj
));
717 strout (buf
, -1, printcharfun
);
722 print_string (obj
, printcharfun
);
726 register unsigned char c
;
730 /* You can't gcpro register variables, so copy obj to a
731 non-register variable so we can gcpro it without
732 making it non-register. */
737 for (i
= 0; i
< XSTRING (obj
)->size
; i
++)
740 c
= XSTRING (obj
)->data
[i
];
741 if (c
== '\n' && print_escape_newlines
)
748 if (c
== '\"' || c
== '\\')
760 register int confusing
;
761 register unsigned char *p
= XSYMBOL (obj
)->name
->data
;
762 register unsigned char *end
= p
+ XSYMBOL (obj
)->name
->size
;
763 register unsigned char c
;
765 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
770 while (p
!= end
&& *p
>= '0' && *p
<= '9')
772 confusing
= (end
== p
);
775 p
= XSYMBOL (obj
)->name
->data
;
782 if (c
== '\"' || c
== '\\' || c
== '\'' || c
== ';' || c
== '#' ||
783 c
== '(' || c
== ')' || c
== ',' || c
=='.' || c
== '`' ||
784 c
== '[' || c
== ']' || c
== '?' || c
<= 040 || confusing
)
785 PRINTCHAR ('\\'), confusing
= 0;
793 /* If deeper than spec'd depth, print placeholder. */
794 if (XTYPE (Vprint_level
) == Lisp_Int
795 && print_depth
> XINT (Vprint_level
))
797 strout ("...", -1, printcharfun
);
804 register int max
= 0;
806 if (XTYPE (Vprint_length
) == Lisp_Int
)
807 max
= XINT (Vprint_length
);
808 /* Could recognize circularities in cdrs here,
809 but that would make printing of long lists quadratic.
810 It's not worth doing. */
817 strout ("...", 3, printcharfun
);
820 print (Fcar (obj
), printcharfun
, escapeflag
);
824 if (!NILP (obj
) && !CONSP (obj
))
826 strout (" . ", 3, printcharfun
);
827 print (obj
, printcharfun
, escapeflag
);
833 strout ("#", -1, printcharfun
);
838 register Lisp_Object tem
;
839 for (i
= 0; i
< XVECTOR (obj
)->size
; i
++)
841 if (i
) PRINTCHAR (' ');
842 tem
= XVECTOR (obj
)->contents
[i
];
843 print (tem
, printcharfun
, escapeflag
);
851 if (NILP (XBUFFER (obj
)->name
))
852 strout ("#<killed buffer>", -1, printcharfun
);
855 strout ("#<buffer ", -1, printcharfun
);
856 print_string (XBUFFER (obj
)->name
, printcharfun
);
860 print_string (XBUFFER (obj
)->name
, printcharfun
);
866 strout ("#<process ", -1, printcharfun
);
867 print_string (XPROCESS (obj
)->name
, printcharfun
);
871 print_string (XPROCESS (obj
)->name
, printcharfun
);
875 strout ("#<window ", -1, printcharfun
);
876 sprintf (buf
, "%d", XFASTINT (XWINDOW (obj
)->sequence_number
));
877 strout (buf
, -1, printcharfun
);
878 if (!NILP (XWINDOW (obj
)->buffer
))
880 strout (" on ", -1, printcharfun
);
881 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
886 case Lisp_Window_Configuration
:
887 strout ("#<window-configuration>", -1, printcharfun
);
892 strout (((XSCREEN (obj
)->display
.nothing
== 0)
893 ? "#<dead screen " : "#<screen "),
895 print_string (XSCREEN (obj
)->name
, printcharfun
);
896 sprintf (buf
, " 0x%x", XFASTINT (XSCREEN (obj
)));
897 strout (buf
, -1, printcharfun
);
898 strout (">", -1, printcharfun
);
900 #endif /* MULTI_SCREEN */
903 strout ("#<marker ", -1, printcharfun
);
904 if (!(XMARKER (obj
)->buffer
))
905 strout ("in no buffer", -1, printcharfun
);
908 sprintf (buf
, "at %d", marker_position (obj
));
909 strout (buf
, -1, printcharfun
);
910 strout (" in ", -1, printcharfun
);
911 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
915 #endif /* standalone */
918 strout ("#<subr ", -1, printcharfun
);
919 strout (XSUBR (obj
)->symbol_name
, -1, printcharfun
);
930 staticpro (&Qprint_escape_newlines
);
931 Qprint_escape_newlines
= intern ("print-escape-newlines");
933 DEFVAR_LISP ("standard-output", &Vstandard_output
,
934 "Output stream `print' uses by default for outputting a character.\n\
935 This may be any function of one argument.\n\
936 It may also be a buffer (output is inserted before point)\n\
937 or a marker (output is inserted and the marker is advanced)\n\
938 or the symbol t (output appears in the minibuffer line).");
939 Vstandard_output
= Qt
;
940 Qstandard_output
= intern ("standard-output");
941 staticpro (&Qstandard_output
);
943 #ifdef LISP_FLOAT_TYPE
944 DEFVAR_LISP ("float-output-format", &Vfloat_output_format
,
945 "The format descriptor string used to print floats.\n\
946 This is a %-spec like those accepted by `printf' in C,\n\
947 but with some restrictions. It must start with the two characters `%.'.\n\
948 After that comes an integer precision specification,\n\
949 and then a letter which controls the format.\n\
950 The letters allowed are `e', `f' and `g'.\n\
951 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"\n\
952 Use `f' for decimal point notation \"DIGITS.DIGITS\".\n\
953 Use `g' to choose the shorter of those two formats for the number at hand.\n\
954 The precision in any of these cases is the number of digits following\n\
955 the decimal point. With `f', a precision of 0 means to omit the\n\
956 decimal point. 0 is not allowed with `f' or `g'.\n\n\
957 A value of nil means to use `%.20g'.");
958 Vfloat_output_format
= Qnil
;
959 Qfloat_output_format
= intern ("float-output-format");
960 staticpro (&Qfloat_output_format
);
961 #endif /* LISP_FLOAT_TYPE */
963 DEFVAR_LISP ("print-length", &Vprint_length
,
964 "Maximum length of list to print before abbreviating.\n\
965 A value of nil means no limit.");
966 Vprint_length
= Qnil
;
968 DEFVAR_LISP ("print-level", &Vprint_level
,
969 "Maximum depth of list nesting to print before abbreviating.\n\
970 A value of nil means no limit.");
973 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines
,
974 "Non-nil means print newlines in strings as backslash-n.");
975 print_escape_newlines
= 0;
977 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
978 staticpro (&Vprin1_to_string_buffer
);
981 defsubr (&Sprin1_to_string
);
985 defsubr (&Swrite_char
);
986 defsubr (&Sexternal_debugging_output
);
988 Qexternal_debugging_output
= intern ("external-debugging-output");
989 staticpro (&Qexternal_debugging_output
);
992 defsubr (&Swith_output_to_temp_buffer
);
993 #endif /* not standalone */