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. */
31 #include "dispextern.h"
34 #endif /* not standalone */
36 #ifdef USE_TEXT_PROPERTIES
37 #include "intervals.h"
40 Lisp_Object Vstandard_output
, Qstandard_output
;
42 #ifdef LISP_FLOAT_TYPE
43 Lisp_Object Vfloat_output_format
, Qfloat_output_format
;
44 #endif /* LISP_FLOAT_TYPE */
46 /* Avoid actual stack overflow in print. */
49 /* Detect most circularities to print finite output. */
50 #define PRINT_CIRCLE 200
51 Lisp_Object being_printed
[PRINT_CIRCLE
];
53 /* Maximum length of list to print in full; noninteger means
54 effectively infinity */
56 Lisp_Object Vprint_length
;
58 /* Maximum depth of list to print in full; noninteger means
59 effectively infinity. */
61 Lisp_Object Vprint_level
;
63 /* Nonzero means print newlines in strings as \n. */
65 int print_escape_newlines
;
67 Lisp_Object Qprint_escape_newlines
;
69 /* Nonzero means print newline to stdout before next minibuffer message.
72 extern int noninteractive_need_newline
;
74 #ifdef MAX_PRINT_CHARS
75 static int print_chars
;
77 #endif /* MAX_PRINT_CHARS */
79 void print_interval ();
82 /* Convert between chars and GLYPHs */
86 register GLYPH
*glyphs
;
96 str_to_glyph_cpy (str
, glyphs
)
100 register GLYPH
*gp
= glyphs
;
101 register char *cp
= str
;
108 str_to_glyph_ncpy (str
, glyphs
, n
)
113 register GLYPH
*gp
= glyphs
;
114 register char *cp
= str
;
121 glyph_to_str_cpy (glyphs
, str
)
125 register GLYPH
*gp
= glyphs
;
126 register char *cp
= str
;
129 *str
++ = *gp
++ & 0377;
133 /* Low level output routines for characters and strings */
135 /* Lisp functions to do output using a stream
136 must have the stream in a variable called printcharfun
137 and must start with PRINTPREPARE and end with PRINTFINISH.
138 Use PRINTCHAR to output one character,
139 or call strout to output a block of characters.
140 Also, each one must have the declarations
141 struct buffer *old = current_buffer;
142 int old_point = -1, start_point;
143 Lisp_Object original;
146 #define PRINTPREPARE \
147 original = printcharfun; \
148 if (NILP (printcharfun)) printcharfun = Qt; \
149 if (BUFFERP (printcharfun)) \
150 { if (XBUFFER (printcharfun) != current_buffer) \
151 Fset_buffer (printcharfun); \
152 printcharfun = Qnil;} \
153 if (MARKERP (printcharfun)) \
154 { if (!(XMARKER (original)->buffer)) \
155 error ("Marker does not point anywhere"); \
156 if (XMARKER (original)->buffer != current_buffer) \
157 set_buffer_internal (XMARKER (original)->buffer); \
159 SET_PT (marker_position (printcharfun)); \
160 start_point = point; \
161 printcharfun = Qnil;}
163 #define PRINTFINISH \
164 if (MARKERP (original)) \
165 Fset_marker (original, make_number (point), Qnil); \
166 if (old_point >= 0) \
167 SET_PT (old_point + (old_point >= start_point \
168 ? point - start_point : 0)); \
169 if (old != current_buffer) \
170 set_buffer_internal (old)
172 #define PRINTCHAR(ch) printchar (ch, printcharfun)
174 /* Index of first unused element of FRAME_MESSAGE_BUF(mini_frame). */
175 static int printbufidx
;
184 #ifdef MAX_PRINT_CHARS
187 #endif /* MAX_PRINT_CHARS */
199 = XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window
)));
204 noninteractive_need_newline
= 1;
208 if (echo_area_glyphs
!= FRAME_MESSAGE_BUF (mini_frame
)
209 || !message_buf_print
)
211 message_log_maybe_newline ();
212 echo_area_glyphs
= FRAME_MESSAGE_BUF (mini_frame
);
214 echo_area_glyphs_length
= 0;
215 message_buf_print
= 1;
218 message_dolog (&ch
, 1, 0);
219 if (printbufidx
< FRAME_WIDTH (mini_frame
) - 1)
220 FRAME_MESSAGE_BUF (mini_frame
)[printbufidx
++] = ch
;
221 FRAME_MESSAGE_BUF (mini_frame
)[printbufidx
] = 0;
222 echo_area_glyphs_length
= printbufidx
;
226 #endif /* not standalone */
228 XSETFASTINT (ch1
, ch
);
233 strout (ptr
, size
, printcharfun
)
236 Lisp_Object printcharfun
;
240 if (EQ (printcharfun
, Qnil
))
242 insert (ptr
, size
>= 0 ? size
: strlen (ptr
));
243 #ifdef MAX_PRINT_CHARS
245 print_chars
+= size
>= 0 ? size
: strlen(ptr
);
246 #endif /* MAX_PRINT_CHARS */
249 if (EQ (printcharfun
, Qt
))
252 = XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window
)));
254 i
= size
>= 0 ? size
: strlen (ptr
);
255 #ifdef MAX_PRINT_CHARS
258 #endif /* MAX_PRINT_CHARS */
262 fwrite (ptr
, 1, i
, stdout
);
263 noninteractive_need_newline
= 1;
267 if (echo_area_glyphs
!= FRAME_MESSAGE_BUF (mini_frame
)
268 || !message_buf_print
)
270 message_log_maybe_newline ();
271 echo_area_glyphs
= FRAME_MESSAGE_BUF (mini_frame
);
273 echo_area_glyphs_length
= 0;
274 message_buf_print
= 1;
277 message_dolog (ptr
, i
, 0);
278 if (i
> FRAME_WIDTH (mini_frame
) - printbufidx
- 1)
279 i
= FRAME_WIDTH (mini_frame
) - printbufidx
- 1;
280 bcopy (ptr
, &FRAME_MESSAGE_BUF (mini_frame
) [printbufidx
], i
);
282 echo_area_glyphs_length
= printbufidx
;
283 FRAME_MESSAGE_BUF (mini_frame
) [printbufidx
] = 0;
290 PRINTCHAR (ptr
[i
++]);
293 PRINTCHAR (ptr
[i
++]);
296 /* Print the contents of a string STRING using PRINTCHARFUN.
297 It isn't safe to use strout in many cases,
298 because printing one char can relocate. */
300 print_string (string
, printcharfun
)
302 Lisp_Object printcharfun
;
304 if (EQ (printcharfun
, Qt
))
305 /* strout is safe for output to a frame (echo area). */
306 strout (XSTRING (string
)->data
, XSTRING (string
)->size
, printcharfun
);
307 else if (EQ (printcharfun
, Qnil
))
309 #ifdef MAX_PRINT_CHARS
311 print_chars
+= XSTRING (string
)->size
;
312 #endif /* MAX_PRINT_CHARS */
313 insert_from_string (string
, 0, XSTRING (string
)->size
, 1);
317 /* Otherwise, fetch the string address for each character. */
319 int size
= XSTRING (string
)->size
;
322 for (i
= 0; i
< size
; i
++)
323 PRINTCHAR (XSTRING (string
)->data
[i
]);
328 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
329 "Output character CHARACTER to stream PRINTCHARFUN.\n\
330 PRINTCHARFUN defaults to the value of `standard-output' (which see).")
331 (character
, printcharfun
)
332 Lisp_Object character
, printcharfun
;
334 struct buffer
*old
= current_buffer
;
337 Lisp_Object original
;
339 if (NILP (printcharfun
))
340 printcharfun
= Vstandard_output
;
341 CHECK_NUMBER (character
, 0);
343 PRINTCHAR (XINT (character
));
348 /* Used from outside of print.c to print a block of SIZE chars at DATA
349 on the default output stream.
350 Do not use this on the contents of a Lisp string. */
352 write_string (data
, size
)
356 struct buffer
*old
= current_buffer
;
357 Lisp_Object printcharfun
;
360 Lisp_Object original
;
362 printcharfun
= Vstandard_output
;
365 strout (data
, size
, printcharfun
);
369 /* Used from outside of print.c to print a block of SIZE chars at DATA
370 on a specified stream PRINTCHARFUN.
371 Do not use this on the contents of a Lisp string. */
373 write_string_1 (data
, size
, printcharfun
)
376 Lisp_Object printcharfun
;
378 struct buffer
*old
= current_buffer
;
381 Lisp_Object original
;
384 strout (data
, size
, printcharfun
);
392 temp_output_buffer_setup (bufname
)
395 register struct buffer
*old
= current_buffer
;
396 register Lisp_Object buf
;
398 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
400 current_buffer
->directory
= old
->directory
;
401 current_buffer
->read_only
= Qnil
;
404 XSETBUFFER (buf
, current_buffer
);
405 specbind (Qstandard_output
, buf
);
407 set_buffer_internal (old
);
411 internal_with_output_to_temp_buffer (bufname
, function
, args
)
413 Lisp_Object (*function
) ();
416 int count
= specpdl_ptr
- specpdl
;
417 Lisp_Object buf
, val
;
421 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
422 temp_output_buffer_setup (bufname
);
423 buf
= Vstandard_output
;
426 val
= (*function
) (args
);
429 temp_output_buffer_show (buf
);
432 return unbind_to (count
, val
);
435 DEFUN ("with-output-to-temp-buffer", Fwith_output_to_temp_buffer
, Swith_output_to_temp_buffer
,
437 "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.\n\
438 The buffer is cleared out initially, and marked as unmodified when done.\n\
439 All output done by BODY is inserted in that buffer by default.\n\
440 The buffer is displayed in another window, but not selected.\n\
441 The value of the last form in BODY is returned.\n\
442 If BODY does not finish normally, the buffer BUFNAME is not displayed.\n\n\
443 If variable `temp-buffer-show-function' is non-nil, call it at the end\n\
444 to get the buffer displayed. It gets one argument, the buffer to display.")
450 int count
= specpdl_ptr
- specpdl
;
451 Lisp_Object buf
, val
;
454 name
= Feval (Fcar (args
));
457 CHECK_STRING (name
, 0);
458 temp_output_buffer_setup (XSTRING (name
)->data
);
459 buf
= Vstandard_output
;
461 val
= Fprogn (Fcdr (args
));
463 temp_output_buffer_show (buf
);
465 return unbind_to (count
, val
);
467 #endif /* not standalone */
469 static void print ();
471 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
472 "Output a newline to stream PRINTCHARFUN.\n\
473 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used.")
475 Lisp_Object printcharfun
;
477 struct buffer
*old
= current_buffer
;
480 Lisp_Object original
;
482 if (NILP (printcharfun
))
483 printcharfun
= Vstandard_output
;
490 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
491 "Output the printed representation of OBJECT, any Lisp object.\n\
492 Quoting characters are printed when needed to make output that `read'\n\
493 can handle, whenever this is possible.\n\
494 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
495 (object
, printcharfun
)
496 Lisp_Object object
, printcharfun
;
498 struct buffer
*old
= current_buffer
;
501 Lisp_Object original
;
503 #ifdef MAX_PRINT_CHARS
505 #endif /* MAX_PRINT_CHARS */
506 if (NILP (printcharfun
))
507 printcharfun
= Vstandard_output
;
510 print (object
, printcharfun
, 1);
515 /* a buffer which is used to hold output being built by prin1-to-string */
516 Lisp_Object Vprin1_to_string_buffer
;
518 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
519 "Return a string containing the printed representation of OBJECT,\n\
520 any Lisp object. Quoting characters are used when needed to make output\n\
521 that `read' can handle, whenever this is possible, unless the optional\n\
522 second argument NOESCAPE is non-nil.")
524 Lisp_Object object
, noescape
;
526 struct buffer
*old
= current_buffer
;
529 Lisp_Object original
, printcharfun
;
530 struct gcpro gcpro1
, gcpro2
;
533 /* Save and restore this--we are altering a buffer
534 but we don't want to deactivate the mark just for that.
535 No need for specbind, since errors deactivate the mark. */
536 tem
= Vdeactivate_mark
;
537 GCPRO2 (object
, tem
);
539 printcharfun
= Vprin1_to_string_buffer
;
542 print (object
, printcharfun
, NILP (noescape
));
543 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
545 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
546 object
= Fbuffer_string ();
549 set_buffer_internal (old
);
551 Vdeactivate_mark
= tem
;
557 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
558 "Output the printed representation of OBJECT, any Lisp object.\n\
559 No quoting characters are used; no delimiters are printed around\n\
560 the contents of strings.\n\
561 Output stream is PRINTCHARFUN, or value of standard-output (which see).")
562 (object
, printcharfun
)
563 Lisp_Object object
, printcharfun
;
565 struct buffer
*old
= current_buffer
;
568 Lisp_Object original
;
570 if (NILP (printcharfun
))
571 printcharfun
= Vstandard_output
;
574 print (object
, printcharfun
, 0);
579 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
580 "Output the printed representation of OBJECT, with newlines around it.\n\
581 Quoting characters are printed when needed to make output that `read'\n\
582 can handle, whenever this is possible.\n\
583 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
584 (object
, printcharfun
)
585 Lisp_Object object
, printcharfun
;
587 struct buffer
*old
= current_buffer
;
590 Lisp_Object original
;
593 #ifdef MAX_PRINT_CHARS
595 max_print
= MAX_PRINT_CHARS
;
596 #endif /* MAX_PRINT_CHARS */
597 if (NILP (printcharfun
))
598 printcharfun
= Vstandard_output
;
603 print (object
, printcharfun
, 1);
606 #ifdef MAX_PRINT_CHARS
609 #endif /* MAX_PRINT_CHARS */
614 /* The subroutine object for external-debugging-output is kept here
615 for the convenience of the debugger. */
616 Lisp_Object Qexternal_debugging_output
;
618 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
619 "Write CHARACTER to stderr.\n\
620 You can call print while debugging emacs, and pass it this function\n\
621 to make it write to the debugging output.\n")
623 Lisp_Object character
;
625 CHECK_NUMBER (character
, 0);
626 putc (XINT (character
), stderr
);
631 /* This is the interface for debugging printing. */
637 Fprin1 (arg
, Qexternal_debugging_output
);
638 fprintf (stderr
, "\r\n");
641 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
643 "Convert an error value (ERROR-SYMBOL . DATA) to an error message.")
647 struct buffer
*old
= current_buffer
;
648 Lisp_Object original
, printcharfun
, value
;
651 print_error_message (obj
, Vprin1_to_string_buffer
, NULL
);
653 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
654 value
= Fbuffer_string ();
658 set_buffer_internal (old
);
664 /* Print an error message for the error DATA
665 onto Lisp output stream STREAM (suitable for the print functions). */
667 print_error_message (data
, stream
)
668 Lisp_Object data
, stream
;
670 Lisp_Object errname
, errmsg
, file_error
, tail
;
674 errname
= Fcar (data
);
676 if (EQ (errname
, Qerror
))
679 if (!CONSP (data
)) data
= Qnil
;
680 errmsg
= Fcar (data
);
685 errmsg
= Fget (errname
, Qerror_message
);
686 file_error
= Fmemq (Qfile_error
,
687 Fget (errname
, Qerror_conditions
));
690 /* Print an error message including the data items. */
692 tail
= Fcdr_safe (data
);
695 /* For file-error, make error message by concatenating
696 all the data items. They are all strings. */
697 if (!NILP (file_error
) && !NILP (tail
))
698 errmsg
= XCONS (tail
)->car
, tail
= XCONS (tail
)->cdr
;
700 if (STRINGP (errmsg
))
701 Fprinc (errmsg
, stream
);
703 write_string_1 ("peculiar error", -1, stream
);
705 for (i
= 0; CONSP (tail
); tail
= Fcdr (tail
), i
++)
707 write_string_1 (i
? ", " : ": ", 2, stream
);
708 if (!NILP (file_error
))
709 Fprinc (Fcar (tail
), stream
);
711 Fprin1 (Fcar (tail
), stream
);
716 #ifdef LISP_FLOAT_TYPE
719 * The buffer should be at least as large as the max string size of the
720 * largest float, printed in the biggest notation. This is undoubtedly
721 * 20d float_output_format, with the negative of the C-constant "HUGE"
724 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
726 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
727 * case of -1e307 in 20d float_output_format. What is one to do (short of
728 * re-writing _doprnt to be more sane)?
733 float_to_string (buf
, data
)
740 if (NILP (Vfloat_output_format
)
741 || !STRINGP (Vfloat_output_format
))
744 sprintf (buf
, "%.17g", data
);
749 /* Check that the spec we have is fully valid.
750 This means not only valid for printf,
751 but meant for floats, and reasonable. */
752 cp
= XSTRING (Vfloat_output_format
)->data
;
761 /* Check the width specification. */
763 if ('0' <= *cp
&& *cp
<= '9')
767 width
= (width
* 10) + (*cp
++ - '0');
768 while (*cp
>= '0' && *cp
<= '9');
770 /* A precision of zero is valid only for %f. */
772 || (width
== 0 && *cp
!= 'f'))
776 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
782 sprintf (buf
, XSTRING (Vfloat_output_format
)->data
, data
);
785 /* Make sure there is a decimal point with digit after, or an
786 exponent, so that the value is readable as a float. But don't do
787 this with "%.0f"; it's valid for that not to produce a decimal
788 point. Note that width can be 0 only for %.0f. */
791 for (cp
= buf
; *cp
; cp
++)
792 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
795 if (*cp
== '.' && cp
[1] == 0)
809 #endif /* LISP_FLOAT_TYPE */
812 print (obj
, printcharfun
, escapeflag
)
814 register Lisp_Object printcharfun
;
821 #if 1 /* I'm not sure this is really worth doing. */
822 /* Detect circularities and truncate them.
823 No need to offer any alternative--this is better than an error. */
824 if (CONSP (obj
) || VECTORP (obj
) || COMPILEDP (obj
))
827 for (i
= 0; i
< print_depth
; i
++)
828 if (EQ (obj
, being_printed
[i
]))
830 sprintf (buf
, "#%d", i
);
831 strout (buf
, -1, printcharfun
);
837 being_printed
[print_depth
] = obj
;
840 if (print_depth
> PRINT_CIRCLE
)
841 error ("Apparently circular structure being printed");
842 #ifdef MAX_PRINT_CHARS
843 if (max_print
&& print_chars
> max_print
)
848 #endif /* MAX_PRINT_CHARS */
850 switch (XGCTYPE (obj
))
853 if (sizeof (int) == sizeof (EMACS_INT
))
854 sprintf (buf
, "%d", XINT (obj
));
855 else if (sizeof (long) == sizeof (EMACS_INT
))
856 sprintf (buf
, "%ld", XINT (obj
));
859 strout (buf
, -1, printcharfun
);
862 #ifdef LISP_FLOAT_TYPE
865 char pigbuf
[350]; /* see comments in float_to_string */
867 float_to_string (pigbuf
, XFLOAT(obj
)->data
);
868 strout (pigbuf
, -1, printcharfun
);
875 print_string (obj
, printcharfun
);
879 register unsigned char c
;
884 #ifdef USE_TEXT_PROPERTIES
885 if (!NULL_INTERVAL_P (XSTRING (obj
)->intervals
))
893 for (i
= 0; i
< XSTRING (obj
)->size
; i
++)
896 c
= XSTRING (obj
)->data
[i
];
897 if (c
== '\n' && print_escape_newlines
)
902 else if (c
== '\f' && print_escape_newlines
)
909 if (c
== '\"' || c
== '\\')
916 #ifdef USE_TEXT_PROPERTIES
917 if (!NULL_INTERVAL_P (XSTRING (obj
)->intervals
))
919 traverse_intervals (XSTRING (obj
)->intervals
,
920 0, 0, print_interval
, printcharfun
);
931 register int confusing
;
932 register unsigned char *p
= XSYMBOL (obj
)->name
->data
;
933 register unsigned char *end
= p
+ XSYMBOL (obj
)->name
->size
;
934 register unsigned char c
;
936 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
941 while (p
!= end
&& *p
>= '0' && *p
<= '9')
943 confusing
= (end
== p
);
946 p
= XSYMBOL (obj
)->name
->data
;
953 if (c
== '\"' || c
== '\\' || c
== '\'' || c
== ';' || c
== '#' ||
954 c
== '(' || c
== ')' || c
== ',' || c
=='.' || c
== '`' ||
955 c
== '[' || c
== ']' || c
== '?' || c
<= 040 || confusing
)
956 PRINTCHAR ('\\'), confusing
= 0;
964 /* If deeper than spec'd depth, print placeholder. */
965 if (INTEGERP (Vprint_level
)
966 && print_depth
> XINT (Vprint_level
))
967 strout ("...", -1, printcharfun
);
973 register int max
= 0;
975 if (INTEGERP (Vprint_length
))
976 max
= XINT (Vprint_length
);
977 /* Could recognize circularities in cdrs here,
978 but that would make printing of long lists quadratic.
979 It's not worth doing. */
986 strout ("...", 3, printcharfun
);
989 print (Fcar (obj
), printcharfun
, escapeflag
);
993 if (!NILP (obj
) && !CONSP (obj
))
995 strout (" . ", 3, printcharfun
);
996 print (obj
, printcharfun
, escapeflag
);
1002 case Lisp_Vectorlike
:
1007 strout ("#<process ", -1, printcharfun
);
1008 print_string (XPROCESS (obj
)->name
, printcharfun
);
1012 print_string (XPROCESS (obj
)->name
, printcharfun
);
1014 else if (BOOL_VECTOR_P (obj
))
1017 register unsigned char c
;
1018 struct gcpro gcpro1
;
1020 = (XBOOL_VECTOR (obj
)->size
+ BITS_PER_CHAR
) / BITS_PER_CHAR
;
1026 sprintf (buf
, "%d", XBOOL_VECTOR (obj
)->size
);
1027 strout (buf
, -1, printcharfun
);
1029 for (i
= 0; i
< size_in_chars
; i
++)
1032 c
= XBOOL_VECTOR (obj
)->data
[i
];
1033 if (c
== '\n' && print_escape_newlines
)
1038 else if (c
== '\f' && print_escape_newlines
)
1045 if (c
== '\"' || c
== '\\')
1054 else if (SUBRP (obj
))
1056 strout ("#<subr ", -1, printcharfun
);
1057 strout (XSUBR (obj
)->symbol_name
, -1, printcharfun
);
1061 else if (WINDOWP (obj
))
1063 strout ("#<window ", -1, printcharfun
);
1064 sprintf (buf
, "%d", XFASTINT (XWINDOW (obj
)->sequence_number
));
1065 strout (buf
, -1, printcharfun
);
1066 if (!NILP (XWINDOW (obj
)->buffer
))
1068 strout (" on ", -1, printcharfun
);
1069 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1073 else if (BUFFERP (obj
))
1075 if (NILP (XBUFFER (obj
)->name
))
1076 strout ("#<killed buffer>", -1, printcharfun
);
1077 else if (escapeflag
)
1079 strout ("#<buffer ", -1, printcharfun
);
1080 print_string (XBUFFER (obj
)->name
, printcharfun
);
1084 print_string (XBUFFER (obj
)->name
, printcharfun
);
1086 else if (WINDOW_CONFIGURATIONP (obj
))
1088 strout ("#<window-configuration>", -1, printcharfun
);
1091 else if (FRAMEP (obj
))
1093 strout ((FRAME_LIVE_P (XFRAME (obj
))
1094 ? "#<frame " : "#<dead frame "),
1096 print_string (XFRAME (obj
)->name
, printcharfun
);
1097 sprintf (buf
, " 0x%lx", (unsigned long) (XFRAME (obj
)));
1098 strout (buf
, -1, printcharfun
);
1102 #endif /* not standalone */
1105 int size
= XVECTOR (obj
)->size
;
1106 if (COMPILEDP (obj
))
1109 size
&= PSEUDOVECTOR_SIZE_MASK
;
1111 if (CHAR_TABLE_P (obj
))
1113 /* We print a char-table as if it were a vector,
1114 lumping the parent and default slots in with the
1115 character slots. But we add #^ as a prefix. */
1118 size
&= PSEUDOVECTOR_SIZE_MASK
;
1120 if (size
& PSEUDOVECTOR_FLAG
)
1126 register Lisp_Object tem
;
1127 for (i
= 0; i
< size
; i
++)
1129 if (i
) PRINTCHAR (' ');
1130 tem
= XVECTOR (obj
)->contents
[i
];
1131 print (tem
, printcharfun
, escapeflag
);
1140 switch (XMISCTYPE (obj
))
1142 case Lisp_Misc_Marker
:
1143 strout ("#<marker ", -1, printcharfun
);
1144 if (!(XMARKER (obj
)->buffer
))
1145 strout ("in no buffer", -1, printcharfun
);
1148 sprintf (buf
, "at %d", marker_position (obj
));
1149 strout (buf
, -1, printcharfun
);
1150 strout (" in ", -1, printcharfun
);
1151 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
1156 case Lisp_Misc_Overlay
:
1157 strout ("#<overlay ", -1, printcharfun
);
1158 if (!(XMARKER (OVERLAY_START (obj
))->buffer
))
1159 strout ("in no buffer", -1, printcharfun
);
1162 sprintf (buf
, "from %d to %d in ",
1163 marker_position (OVERLAY_START (obj
)),
1164 marker_position (OVERLAY_END (obj
)));
1165 strout (buf
, -1, printcharfun
);
1166 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
1172 /* Remaining cases shouldn't happen in normal usage, but let's print
1173 them anyway for the benefit of the debugger. */
1174 case Lisp_Misc_Free
:
1175 strout ("#<misc free cell>", -1, printcharfun
);
1178 case Lisp_Misc_Intfwd
:
1179 sprintf (buf
, "#<intfwd to %d>", *XINTFWD (obj
)->intvar
);
1180 strout (buf
, -1, printcharfun
);
1183 case Lisp_Misc_Boolfwd
:
1184 sprintf (buf
, "#<boolfwd to %s>",
1185 (*XBOOLFWD (obj
)->boolvar
? "t" : "nil"));
1186 strout (buf
, -1, printcharfun
);
1189 case Lisp_Misc_Objfwd
:
1190 strout (buf
, "#<objfwd to ", -1, printcharfun
);
1191 print (*XOBJFWD (obj
)->objvar
, printcharfun
, escapeflag
);
1195 case Lisp_Misc_Buffer_Objfwd
:
1196 strout (buf
, "#<buffer_objfwd to ", -1, printcharfun
);
1197 print (*(Lisp_Object
*)((char *)current_buffer
1198 + XBUFFER_OBJFWD (obj
)->offset
),
1199 printcharfun
, escapeflag
);
1203 case Lisp_Misc_Kboard_Objfwd
:
1204 strout (buf
, "#<kboard_objfwd to ", -1, printcharfun
);
1205 print (*(Lisp_Object
*)((char *) current_kboard
1206 + XKBOARD_OBJFWD (obj
)->offset
),
1207 printcharfun
, escapeflag
);
1211 case Lisp_Misc_Buffer_Local_Value
:
1212 strout ("#<buffer_local_value ", -1, printcharfun
);
1213 goto do_buffer_local
;
1214 case Lisp_Misc_Some_Buffer_Local_Value
:
1215 strout ("#<some_buffer_local_value ", -1, printcharfun
);
1217 strout ("[realvalue] ", -1, printcharfun
);
1218 print (XBUFFER_LOCAL_VALUE (obj
)->car
, printcharfun
, escapeflag
);
1219 strout ("[buffer] ", -1, printcharfun
);
1220 print (XCONS (XBUFFER_LOCAL_VALUE (obj
)->cdr
)->car
,
1221 printcharfun
, escapeflag
);
1222 strout ("[alist-elt] ", -1, printcharfun
);
1223 print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj
)->cdr
)->cdr
)->car
,
1224 printcharfun
, escapeflag
);
1225 strout ("[default-value] ", -1, printcharfun
);
1226 print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj
)->cdr
)->cdr
)->cdr
,
1227 printcharfun
, escapeflag
);
1235 #endif /* standalone */
1240 /* We're in trouble if this happens!
1241 Probably should just abort () */
1242 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, printcharfun
);
1244 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
1245 else if (VECTORLIKEP (obj
))
1246 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
1248 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
1249 strout (buf
, -1, printcharfun
);
1250 strout (" Save your buffers immediately and please report this bug>",
1258 #ifdef USE_TEXT_PROPERTIES
1260 /* Print a description of INTERVAL using PRINTCHARFUN.
1261 This is part of printing a string that has text properties. */
1264 print_interval (interval
, printcharfun
)
1266 Lisp_Object printcharfun
;
1269 print (make_number (interval
->position
), printcharfun
, 1);
1271 print (make_number (interval
->position
+ LENGTH (interval
)),
1274 print (interval
->plist
, printcharfun
, 1);
1277 #endif /* USE_TEXT_PROPERTIES */
1282 staticpro (&Qprint_escape_newlines
);
1283 Qprint_escape_newlines
= intern ("print-escape-newlines");
1285 DEFVAR_LISP ("standard-output", &Vstandard_output
,
1286 "Output stream `print' uses by default for outputting a character.\n\
1287 This may be any function of one argument.\n\
1288 It may also be a buffer (output is inserted before point)\n\
1289 or a marker (output is inserted and the marker is advanced)\n\
1290 or the symbol t (output appears in the echo area).");
1291 Vstandard_output
= Qt
;
1292 Qstandard_output
= intern ("standard-output");
1293 staticpro (&Qstandard_output
);
1295 #ifdef LISP_FLOAT_TYPE
1296 DEFVAR_LISP ("float-output-format", &Vfloat_output_format
,
1297 "The format descriptor string used to print floats.\n\
1298 This is a %-spec like those accepted by `printf' in C,\n\
1299 but with some restrictions. It must start with the two characters `%.'.\n\
1300 After that comes an integer precision specification,\n\
1301 and then a letter which controls the format.\n\
1302 The letters allowed are `e', `f' and `g'.\n\
1303 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"\n\
1304 Use `f' for decimal point notation \"DIGITS.DIGITS\".\n\
1305 Use `g' to choose the shorter of those two formats for the number at hand.\n\
1306 The precision in any of these cases is the number of digits following\n\
1307 the decimal point. With `f', a precision of 0 means to omit the\n\
1308 decimal point. 0 is not allowed with `e' or `g'.\n\n\
1309 A value of nil means to use `%.17g'.");
1310 Vfloat_output_format
= Qnil
;
1311 Qfloat_output_format
= intern ("float-output-format");
1312 staticpro (&Qfloat_output_format
);
1313 #endif /* LISP_FLOAT_TYPE */
1315 DEFVAR_LISP ("print-length", &Vprint_length
,
1316 "Maximum length of list to print before abbreviating.\n\
1317 A value of nil means no limit.");
1318 Vprint_length
= Qnil
;
1320 DEFVAR_LISP ("print-level", &Vprint_level
,
1321 "Maximum depth of list nesting to print before abbreviating.\n\
1322 A value of nil means no limit.");
1323 Vprint_level
= Qnil
;
1325 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines
,
1326 "Non-nil means print newlines in strings as backslash-n.\n\
1327 Also print formfeeds as backslash-f.");
1328 print_escape_newlines
= 0;
1330 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
1331 staticpro (&Vprin1_to_string_buffer
);
1334 defsubr (&Sprin1_to_string
);
1335 defsubr (&Serror_message_string
);
1339 defsubr (&Swrite_char
);
1340 defsubr (&Sexternal_debugging_output
);
1342 Qexternal_debugging_output
= intern ("external-debugging-output");
1343 staticpro (&Qexternal_debugging_output
);
1346 defsubr (&Swith_output_to_temp_buffer
);
1347 #endif /* not standalone */