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 /* Nonzero means print #: before uninterned symbols. */
90 /* Association list of certain objects that are `eq' in the form being
91 printed and which should be `eq' when read back in, using the #n=object
92 and #n# reader forms. Each element has the form (object . n). */
94 Lisp_Object printed_gensyms
;
96 /* Nonzero means print newline to stdout before next minibuffer message.
99 extern int noninteractive_need_newline
;
101 #ifdef MAX_PRINT_CHARS
102 static int print_chars
;
103 static int max_print
;
104 #endif /* MAX_PRINT_CHARS */
106 void print_interval ();
109 /* Convert between chars and GLYPHs */
113 register GLYPH
*glyphs
;
123 str_to_glyph_cpy (str
, glyphs
)
127 register GLYPH
*gp
= glyphs
;
128 register char *cp
= str
;
135 str_to_glyph_ncpy (str
, glyphs
, n
)
140 register GLYPH
*gp
= glyphs
;
141 register char *cp
= str
;
148 glyph_to_str_cpy (glyphs
, str
)
152 register GLYPH
*gp
= glyphs
;
153 register char *cp
= str
;
156 *str
++ = *gp
++ & 0377;
160 /* Low level output routines for characters and strings */
162 /* Lisp functions to do output using a stream
163 must have the stream in a variable called printcharfun
164 and must start with PRINTPREPARE, end with PRINTFINISH,
165 and use PRINTDECLARE to declare common variables.
166 Use PRINTCHAR to output one character,
167 or call strout to output a block of characters.
170 #define PRINTDECLARE \
171 struct buffer *old = current_buffer; \
172 int old_point = -1, start_point; \
173 int specpdl_count = specpdl_ptr - specpdl; \
174 int free_print_buffer = 0; \
177 #define PRINTPREPARE \
178 original = printcharfun; \
179 if (NILP (printcharfun)) printcharfun = Qt; \
180 if (BUFFERP (printcharfun)) \
182 if (XBUFFER (printcharfun) != current_buffer) \
183 Fset_buffer (printcharfun); \
184 printcharfun = Qnil; \
186 if (MARKERP (printcharfun)) \
188 if (!(XMARKER (original)->buffer)) \
189 error ("Marker does not point anywhere"); \
190 if (XMARKER (original)->buffer != current_buffer) \
191 set_buffer_internal (XMARKER (original)->buffer); \
193 SET_PT (marker_position (printcharfun)); \
195 printcharfun = Qnil; \
197 if (NILP (printcharfun)) \
199 if (print_buffer != 0) \
200 record_unwind_protect (print_unwind, \
201 make_string (print_buffer, \
202 print_buffer_pos)); \
205 print_buffer_size = 1000; \
206 print_buffer = (char *) xmalloc (print_buffer_size); \
207 free_print_buffer = 1; \
209 print_buffer_pos = 0; \
211 printed_gensyms = Qnil
213 #define PRINTFINISH \
214 if (NILP (printcharfun)) \
215 insert (print_buffer, print_buffer_pos); \
216 if (free_print_buffer) \
218 xfree (print_buffer); \
221 unbind_to (specpdl_count, Qnil); \
222 if (MARKERP (original)) \
223 Fset_marker (original, make_number (PT), Qnil); \
224 if (old_point >= 0) \
225 SET_PT (old_point + (old_point >= start_point \
226 ? PT - start_point : 0)); \
227 if (old != current_buffer) \
228 set_buffer_internal (old); \
229 printed_gensyms = Qnil
231 #define PRINTCHAR(ch) printchar (ch, printcharfun)
233 /* Nonzero if there is no room to print any more characters
234 so print might as well return right away. */
236 #define PRINTFULLP() \
237 (EQ (printcharfun, Qt) && !noninteractive \
238 && printbufidx >= FRAME_WIDTH (XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window)))))
240 /* This is used to restore the saved contents of print_buffer
241 when there is a recursive call to print. */
243 print_unwind (saved_text
)
244 Lisp_Object saved_text
;
246 bcopy (XSTRING (saved_text
)->data
, print_buffer
, XSTRING (saved_text
)->size
);
249 /* Index of first unused element of FRAME_MESSAGE_BUF (mini_frame). */
250 static int printbufidx
;
259 #ifdef MAX_PRINT_CHARS
262 #endif /* MAX_PRINT_CHARS */
270 len
= CHAR_STRING (ch
, work
, str
);
271 if (print_buffer_pos
+ len
>= print_buffer_size
)
272 print_buffer
= (char *) xrealloc (print_buffer
,
273 print_buffer_size
*= 2);
274 bcopy (str
, print_buffer
+ print_buffer_pos
, len
);
275 print_buffer_pos
+= len
;
282 = XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window
)));
283 unsigned char work
[4], *str
;
284 int len
= CHAR_STRING (ch
, work
, str
);
291 putchar (*str
), str
++;
292 noninteractive_need_newline
= 1;
296 if (echo_area_glyphs
!= FRAME_MESSAGE_BUF (mini_frame
)
297 || !message_buf_print
)
299 message_log_maybe_newline ();
300 echo_area_glyphs
= FRAME_MESSAGE_BUF (mini_frame
);
302 echo_area_glyphs_length
= 0;
303 message_buf_print
= 1;
306 message_dolog (str
, len
, 0);
307 if (printbufidx
< FRAME_MESSAGE_BUF_SIZE (mini_frame
) - len
)
308 bcopy (str
, &FRAME_MESSAGE_BUF (mini_frame
)[printbufidx
], len
),
310 FRAME_MESSAGE_BUF (mini_frame
)[printbufidx
] = 0;
311 echo_area_glyphs_length
= printbufidx
;
315 #endif /* not standalone */
317 XSETFASTINT (ch1
, ch
);
322 strout (ptr
, size
, printcharfun
)
325 Lisp_Object printcharfun
;
332 if (EQ (printcharfun
, Qnil
))
334 if (print_buffer_pos
+ size
> print_buffer_size
)
336 print_buffer_size
= print_buffer_size
* 2 + size
;
337 print_buffer
= (char *) xrealloc (print_buffer
,
340 bcopy (ptr
, print_buffer
+ print_buffer_pos
, size
);
341 print_buffer_pos
+= size
;
343 #ifdef MAX_PRINT_CHARS
346 #endif /* MAX_PRINT_CHARS */
349 if (EQ (printcharfun
, Qt
))
352 = XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window
)));
356 #ifdef MAX_PRINT_CHARS
359 #endif /* MAX_PRINT_CHARS */
363 fwrite (ptr
, 1, size
, stdout
);
364 noninteractive_need_newline
= 1;
368 if (echo_area_glyphs
!= FRAME_MESSAGE_BUF (mini_frame
)
369 || !message_buf_print
)
371 message_log_maybe_newline ();
372 echo_area_glyphs
= FRAME_MESSAGE_BUF (mini_frame
);
374 echo_area_glyphs_length
= 0;
375 message_buf_print
= 1;
378 message_dolog (ptr
, size
, 0);
379 if (size
> FRAME_MESSAGE_BUF_SIZE (mini_frame
) - printbufidx
- 1)
381 size
= FRAME_MESSAGE_BUF_SIZE (mini_frame
) - printbufidx
- 1;
382 /* Rewind incomplete multi-byte form. */
383 while (size
&& (unsigned char) ptr
[size
] >= 0xA0) size
--;
385 bcopy (ptr
, &FRAME_MESSAGE_BUF (mini_frame
) [printbufidx
], size
);
387 echo_area_glyphs_length
= printbufidx
;
388 FRAME_MESSAGE_BUF (mini_frame
) [printbufidx
] = 0;
396 /* Here, we must convert each multi-byte form to the
397 corresponding character code before handing it to PRINTCHAR. */
399 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size
- i
, len
);
406 /* Print the contents of a string STRING using PRINTCHARFUN.
407 It isn't safe to use strout in many cases,
408 because printing one char can relocate. */
410 print_string (string
, printcharfun
)
412 Lisp_Object printcharfun
;
414 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
415 /* strout is safe for output to a frame (echo area) or to print_buffer. */
416 strout (XSTRING (string
)->data
, XSTRING (string
)->size
, printcharfun
);
419 /* Otherwise, fetch the string address for each character. */
421 int size
= XSTRING (string
)->size
;
424 for (i
= 0; i
< size
; i
++)
425 PRINTCHAR (XSTRING (string
)->data
[i
]);
430 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
431 "Output character CHARACTER to stream PRINTCHARFUN.\n\
432 PRINTCHARFUN defaults to the value of `standard-output' (which see).")
433 (character
, printcharfun
)
434 Lisp_Object character
, printcharfun
;
438 if (NILP (printcharfun
))
439 printcharfun
= Vstandard_output
;
440 CHECK_NUMBER (character
, 0);
442 PRINTCHAR (XINT (character
));
447 /* Used from outside of print.c to print a block of SIZE chars at DATA
448 on the default output stream.
449 Do not use this on the contents of a Lisp string. */
451 write_string (data
, size
)
456 Lisp_Object printcharfun
;
458 printcharfun
= Vstandard_output
;
461 strout (data
, size
, printcharfun
);
465 /* Used from outside of print.c to print a block of SIZE chars at DATA
466 on a specified stream PRINTCHARFUN.
467 Do not use this on the contents of a Lisp string. */
469 write_string_1 (data
, size
, printcharfun
)
472 Lisp_Object printcharfun
;
477 strout (data
, size
, printcharfun
);
485 temp_output_buffer_setup (bufname
)
488 register struct buffer
*old
= current_buffer
;
489 register Lisp_Object buf
;
491 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
493 current_buffer
->directory
= old
->directory
;
494 current_buffer
->read_only
= Qnil
;
497 XSETBUFFER (buf
, current_buffer
);
498 specbind (Qstandard_output
, buf
);
500 set_buffer_internal (old
);
504 internal_with_output_to_temp_buffer (bufname
, function
, args
)
506 Lisp_Object (*function
) ();
509 int count
= specpdl_ptr
- specpdl
;
510 Lisp_Object buf
, val
;
514 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
515 temp_output_buffer_setup (bufname
);
516 buf
= Vstandard_output
;
519 val
= (*function
) (args
);
522 temp_output_buffer_show (buf
);
525 return unbind_to (count
, val
);
528 DEFUN ("with-output-to-temp-buffer", Fwith_output_to_temp_buffer
, Swith_output_to_temp_buffer
,
530 "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.\n\
531 The buffer is cleared out initially, and marked as unmodified when done.\n\
532 All output done by BODY is inserted in that buffer by default.\n\
533 The buffer is displayed in another window, but not selected.\n\
534 The value of the last form in BODY is returned.\n\
535 If BODY does not finish normally, the buffer BUFNAME is not displayed.\n\n\
536 If variable `temp-buffer-show-function' is non-nil, call it at the end\n\
537 to get the buffer displayed. It gets one argument, the buffer to display.")
543 int count
= specpdl_ptr
- specpdl
;
544 Lisp_Object buf
, val
;
547 name
= Feval (Fcar (args
));
550 CHECK_STRING (name
, 0);
551 temp_output_buffer_setup (XSTRING (name
)->data
);
552 buf
= Vstandard_output
;
554 val
= Fprogn (Fcdr (args
));
556 temp_output_buffer_show (buf
);
558 return unbind_to (count
, val
);
560 #endif /* not standalone */
562 static void print ();
564 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
565 "Output a newline to stream PRINTCHARFUN.\n\
566 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used.")
568 Lisp_Object printcharfun
;
572 if (NILP (printcharfun
))
573 printcharfun
= Vstandard_output
;
580 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
581 "Output the printed representation of OBJECT, any Lisp object.\n\
582 Quoting characters are printed when needed to make output that `read'\n\
583 can handle, whenever this is possible.\n\
584 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
585 (object
, printcharfun
)
586 Lisp_Object object
, printcharfun
;
590 #ifdef MAX_PRINT_CHARS
592 #endif /* MAX_PRINT_CHARS */
593 if (NILP (printcharfun
))
594 printcharfun
= Vstandard_output
;
597 print (object
, printcharfun
, 1);
602 /* a buffer which is used to hold output being built by prin1-to-string */
603 Lisp_Object Vprin1_to_string_buffer
;
605 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
606 "Return a string containing the printed representation of OBJECT,\n\
607 any Lisp object. Quoting characters are used when needed to make output\n\
608 that `read' can handle, whenever this is possible, unless the optional\n\
609 second argument NOESCAPE is non-nil.")
611 Lisp_Object object
, noescape
;
614 Lisp_Object printcharfun
;
615 struct gcpro gcpro1
, gcpro2
;
618 /* Save and restore this--we are altering a buffer
619 but we don't want to deactivate the mark just for that.
620 No need for specbind, since errors deactivate the mark. */
621 tem
= Vdeactivate_mark
;
622 GCPRO2 (object
, tem
);
624 printcharfun
= Vprin1_to_string_buffer
;
627 print (object
, printcharfun
, NILP (noescape
));
628 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
630 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
631 object
= Fbuffer_string ();
634 set_buffer_internal (old
);
636 Vdeactivate_mark
= tem
;
642 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
643 "Output the printed representation of OBJECT, any Lisp object.\n\
644 No quoting characters are used; no delimiters are printed around\n\
645 the contents of strings.\n\
646 Output stream is PRINTCHARFUN, or value of standard-output (which see).")
647 (object
, printcharfun
)
648 Lisp_Object object
, printcharfun
;
652 if (NILP (printcharfun
))
653 printcharfun
= Vstandard_output
;
656 print (object
, printcharfun
, 0);
661 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
662 "Output the printed representation of OBJECT, with newlines around it.\n\
663 Quoting characters are printed when needed to make output that `read'\n\
664 can handle, whenever this is possible.\n\
665 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
666 (object
, printcharfun
)
667 Lisp_Object object
, printcharfun
;
672 #ifdef MAX_PRINT_CHARS
674 max_print
= MAX_PRINT_CHARS
;
675 #endif /* MAX_PRINT_CHARS */
676 if (NILP (printcharfun
))
677 printcharfun
= Vstandard_output
;
682 print (object
, printcharfun
, 1);
685 #ifdef MAX_PRINT_CHARS
688 #endif /* MAX_PRINT_CHARS */
693 /* The subroutine object for external-debugging-output is kept here
694 for the convenience of the debugger. */
695 Lisp_Object Qexternal_debugging_output
;
697 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
698 "Write CHARACTER to stderr.\n\
699 You can call print while debugging emacs, and pass it this function\n\
700 to make it write to the debugging output.\n")
702 Lisp_Object character
;
704 CHECK_NUMBER (character
, 0);
705 putc (XINT (character
), stderr
);
710 /* This is the interface for debugging printing. */
716 Fprin1 (arg
, Qexternal_debugging_output
);
717 fprintf (stderr
, "\r\n");
720 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
722 "Convert an error value (ERROR-SYMBOL . DATA) to an error message.")
726 struct buffer
*old
= current_buffer
;
727 Lisp_Object original
, printcharfun
, value
;
730 /* If OBJ is (error STRING), just return STRING.
731 That is not only faster, it also avoids the need to allocate
732 space here when the error is due to memory full. */
733 if (CONSP (obj
) && EQ (XCONS (obj
)->car
, Qerror
)
734 && CONSP (XCONS (obj
)->cdr
)
735 && STRINGP (XCONS (XCONS (obj
)->cdr
)->car
)
736 && NILP (XCONS (XCONS (obj
)->cdr
)->cdr
))
737 return XCONS (XCONS (obj
)->cdr
)->car
;
739 print_error_message (obj
, Vprin1_to_string_buffer
, NULL
);
741 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
742 value
= Fbuffer_string ();
746 set_buffer_internal (old
);
752 /* Print an error message for the error DATA
753 onto Lisp output stream STREAM (suitable for the print functions). */
755 print_error_message (data
, stream
)
756 Lisp_Object data
, stream
;
758 Lisp_Object errname
, errmsg
, file_error
, tail
;
762 errname
= Fcar (data
);
764 if (EQ (errname
, Qerror
))
767 if (!CONSP (data
)) data
= Qnil
;
768 errmsg
= Fcar (data
);
773 errmsg
= Fget (errname
, Qerror_message
);
774 file_error
= Fmemq (Qfile_error
,
775 Fget (errname
, Qerror_conditions
));
778 /* Print an error message including the data items. */
780 tail
= Fcdr_safe (data
);
783 /* For file-error, make error message by concatenating
784 all the data items. They are all strings. */
785 if (!NILP (file_error
) && !NILP (tail
))
786 errmsg
= XCONS (tail
)->car
, tail
= XCONS (tail
)->cdr
;
788 if (STRINGP (errmsg
))
789 Fprinc (errmsg
, stream
);
791 write_string_1 ("peculiar error", -1, stream
);
793 for (i
= 0; CONSP (tail
); tail
= Fcdr (tail
), i
++)
795 write_string_1 (i
? ", " : ": ", 2, stream
);
796 if (!NILP (file_error
))
797 Fprinc (Fcar (tail
), stream
);
799 Fprin1 (Fcar (tail
), stream
);
804 #ifdef LISP_FLOAT_TYPE
807 * The buffer should be at least as large as the max string size of the
808 * largest float, printed in the biggest notation. This is undoubtedly
809 * 20d float_output_format, with the negative of the C-constant "HUGE"
812 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
814 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
815 * case of -1e307 in 20d float_output_format. What is one to do (short of
816 * re-writing _doprnt to be more sane)?
821 float_to_string (buf
, data
)
828 if (NILP (Vfloat_output_format
)
829 || !STRINGP (Vfloat_output_format
))
832 sprintf (buf
, "%.17g", data
);
837 /* Check that the spec we have is fully valid.
838 This means not only valid for printf,
839 but meant for floats, and reasonable. */
840 cp
= XSTRING (Vfloat_output_format
)->data
;
849 /* Check the width specification. */
851 if ('0' <= *cp
&& *cp
<= '9')
855 width
= (width
* 10) + (*cp
++ - '0');
856 while (*cp
>= '0' && *cp
<= '9');
858 /* A precision of zero is valid only for %f. */
860 || (width
== 0 && *cp
!= 'f'))
864 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
870 sprintf (buf
, XSTRING (Vfloat_output_format
)->data
, data
);
873 /* Make sure there is a decimal point with digit after, or an
874 exponent, so that the value is readable as a float. But don't do
875 this with "%.0f"; it's valid for that not to produce a decimal
876 point. Note that width can be 0 only for %.0f. */
879 for (cp
= buf
; *cp
; cp
++)
880 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
883 if (*cp
== '.' && cp
[1] == 0)
897 #endif /* LISP_FLOAT_TYPE */
900 print (obj
, printcharfun
, escapeflag
)
902 register Lisp_Object printcharfun
;
909 #if 1 /* I'm not sure this is really worth doing. */
910 /* Detect circularities and truncate them.
911 No need to offer any alternative--this is better than an error. */
912 if (CONSP (obj
) || VECTORP (obj
) || COMPILEDP (obj
))
915 for (i
= 0; i
< print_depth
; i
++)
916 if (EQ (obj
, being_printed
[i
]))
918 sprintf (buf
, "#%d", i
);
919 strout (buf
, -1, printcharfun
);
925 being_printed
[print_depth
] = obj
;
928 if (print_depth
> PRINT_CIRCLE
)
929 error ("Apparently circular structure being printed");
930 #ifdef MAX_PRINT_CHARS
931 if (max_print
&& print_chars
> max_print
)
936 #endif /* MAX_PRINT_CHARS */
938 switch (XGCTYPE (obj
))
941 if (sizeof (int) == sizeof (EMACS_INT
))
942 sprintf (buf
, "%d", XINT (obj
));
943 else if (sizeof (long) == sizeof (EMACS_INT
))
944 sprintf (buf
, "%ld", XINT (obj
));
947 strout (buf
, -1, printcharfun
);
950 #ifdef LISP_FLOAT_TYPE
953 char pigbuf
[350]; /* see comments in float_to_string */
955 float_to_string (pigbuf
, XFLOAT(obj
)->data
);
956 strout (pigbuf
, -1, printcharfun
);
963 print_string (obj
, printcharfun
);
967 register unsigned char c
;
972 #ifdef USE_TEXT_PROPERTIES
973 if (!NULL_INTERVAL_P (XSTRING (obj
)->intervals
))
981 for (i
= 0; i
< XSTRING (obj
)->size
; i
++)
984 c
= XSTRING (obj
)->data
[i
];
985 if (c
== '\n' && print_escape_newlines
)
990 else if (c
== '\f' && print_escape_newlines
)
997 if (c
== '\"' || c
== '\\')
1004 #ifdef USE_TEXT_PROPERTIES
1005 if (!NULL_INTERVAL_P (XSTRING (obj
)->intervals
))
1007 traverse_intervals (XSTRING (obj
)->intervals
,
1008 0, 0, print_interval
, printcharfun
);
1019 register int confusing
;
1020 register unsigned char *p
= XSYMBOL (obj
)->name
->data
;
1021 register unsigned char *end
= p
+ XSYMBOL (obj
)->name
->size
;
1022 register unsigned char c
;
1025 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1028 /* If symbol name begins with a digit, and ends with a digit,
1029 and contains nothing but digits and `e', it could be treated
1030 as a number. So set CONFUSING.
1032 Symbols that contain periods could also be taken as numbers,
1033 but periods are always escaped, so we don't have to worry
1035 else if (*p
>= '0' && *p
<= '9'
1036 && end
[-1] >= '0' && end
[-1] <= '9')
1038 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1039 /* Needed for \2e10. */
1042 confusing
= (end
== p
);
1047 /* If we print an uninterned symbol as part of a complex object and
1048 the flag print-gensym is non-nil, prefix it with #n= to read the
1049 object back with the #n# reader syntax later if needed. */
1050 if (print_gensym
&& NILP (XSYMBOL (obj
)->obarray
))
1052 if (print_depth
> 1)
1055 tem
= Fassq (obj
, printed_gensyms
);
1059 print (XCDR (tem
), printcharfun
, escapeflag
);
1065 if (CONSP (printed_gensyms
))
1066 XSETFASTINT (tem
, XFASTINT (XCDR (XCAR (printed_gensyms
))) + 1);
1068 XSETFASTINT (tem
, 1);
1069 printed_gensyms
= Fcons (Fcons (obj
, tem
), printed_gensyms
);
1072 print (tem
, printcharfun
, escapeflag
);
1080 for (i
= 0; i
< XSYMBOL (obj
)->name
->size
; i
++)
1083 c
= XSYMBOL (obj
)->name
->data
[i
];
1087 if (c
== '\"' || c
== '\\' || c
== '\''
1088 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1089 || c
== ',' || c
=='.' || c
== '`'
1090 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1092 PRINTCHAR ('\\'), confusing
= 0;
1100 /* If deeper than spec'd depth, print placeholder. */
1101 if (INTEGERP (Vprint_level
)
1102 && print_depth
> XINT (Vprint_level
))
1103 strout ("...", -1, printcharfun
);
1104 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1105 && (EQ (XCAR (obj
), Qquote
)))
1108 print (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1110 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1111 && (EQ (XCAR (obj
), Qfunction
)))
1115 print (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1117 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1118 && ((EQ (XCAR (obj
), Qbackquote
)
1119 || EQ (XCAR (obj
), Qcomma
)
1120 || EQ (XCAR (obj
), Qcomma_at
)
1121 || EQ (XCAR (obj
), Qcomma_dot
))))
1123 print (XCAR (obj
), printcharfun
, 0);
1124 print (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1131 register int max
= 0;
1133 if (INTEGERP (Vprint_length
))
1134 max
= XINT (Vprint_length
);
1135 /* Could recognize circularities in cdrs here,
1136 but that would make printing of long lists quadratic.
1137 It's not worth doing. */
1144 strout ("...", 3, printcharfun
);
1147 print (XCAR (obj
), printcharfun
, escapeflag
);
1153 strout (" . ", 3, printcharfun
);
1154 print (obj
, printcharfun
, escapeflag
);
1160 case Lisp_Vectorlike
:
1165 strout ("#<process ", -1, printcharfun
);
1166 print_string (XPROCESS (obj
)->name
, printcharfun
);
1170 print_string (XPROCESS (obj
)->name
, printcharfun
);
1172 else if (BOOL_VECTOR_P (obj
))
1175 register unsigned char c
;
1176 struct gcpro gcpro1
;
1178 = (XBOOL_VECTOR (obj
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1184 sprintf (buf
, "%d", XBOOL_VECTOR (obj
)->size
);
1185 strout (buf
, -1, printcharfun
);
1188 /* Don't print more characters than the specified maximum. */
1189 if (INTEGERP (Vprint_length
)
1190 && XINT (Vprint_length
) < size_in_chars
)
1191 size_in_chars
= XINT (Vprint_length
);
1193 for (i
= 0; i
< size_in_chars
; i
++)
1196 c
= XBOOL_VECTOR (obj
)->data
[i
];
1197 if (c
== '\n' && print_escape_newlines
)
1202 else if (c
== '\f' && print_escape_newlines
)
1209 if (c
== '\"' || c
== '\\')
1218 else if (SUBRP (obj
))
1220 strout ("#<subr ", -1, printcharfun
);
1221 strout (XSUBR (obj
)->symbol_name
, -1, printcharfun
);
1225 else if (WINDOWP (obj
))
1227 strout ("#<window ", -1, printcharfun
);
1228 sprintf (buf
, "%d", XFASTINT (XWINDOW (obj
)->sequence_number
));
1229 strout (buf
, -1, printcharfun
);
1230 if (!NILP (XWINDOW (obj
)->buffer
))
1232 strout (" on ", -1, printcharfun
);
1233 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1237 else if (BUFFERP (obj
))
1239 if (NILP (XBUFFER (obj
)->name
))
1240 strout ("#<killed buffer>", -1, printcharfun
);
1241 else if (escapeflag
)
1243 strout ("#<buffer ", -1, printcharfun
);
1244 print_string (XBUFFER (obj
)->name
, printcharfun
);
1248 print_string (XBUFFER (obj
)->name
, printcharfun
);
1250 else if (WINDOW_CONFIGURATIONP (obj
))
1252 strout ("#<window-configuration>", -1, printcharfun
);
1254 else if (FRAMEP (obj
))
1256 strout ((FRAME_LIVE_P (XFRAME (obj
))
1257 ? "#<frame " : "#<dead frame "),
1259 print_string (XFRAME (obj
)->name
, printcharfun
);
1260 sprintf (buf
, " 0x%lx", (unsigned long) (XFRAME (obj
)));
1261 strout (buf
, -1, printcharfun
);
1264 #endif /* not standalone */
1267 int size
= XVECTOR (obj
)->size
;
1268 if (COMPILEDP (obj
))
1271 size
&= PSEUDOVECTOR_SIZE_MASK
;
1273 if (CHAR_TABLE_P (obj
))
1275 /* We print a char-table as if it were a vector,
1276 lumping the parent and default slots in with the
1277 character slots. But we add #^ as a prefix. */
1280 if (SUB_CHAR_TABLE_P (obj
))
1282 size
&= PSEUDOVECTOR_SIZE_MASK
;
1284 if (size
& PSEUDOVECTOR_FLAG
)
1290 register Lisp_Object tem
;
1292 /* Don't print more elements than the specified maximum. */
1293 if (INTEGERP (Vprint_length
)
1294 && XINT (Vprint_length
) < size
)
1295 size
= XINT (Vprint_length
);
1297 for (i
= 0; i
< size
; i
++)
1299 if (i
) PRINTCHAR (' ');
1300 tem
= XVECTOR (obj
)->contents
[i
];
1301 print (tem
, printcharfun
, escapeflag
);
1310 switch (XMISCTYPE (obj
))
1312 case Lisp_Misc_Marker
:
1313 strout ("#<marker ", -1, printcharfun
);
1315 /* Do you think this is necessary? */
1316 if (XMARKER (obj
)->insertion_type
!= 0)
1317 strout ("(before-insertion) ", -1, printcharfun
);
1319 if (!(XMARKER (obj
)->buffer
))
1320 strout ("in no buffer", -1, printcharfun
);
1323 sprintf (buf
, "at %d", marker_position (obj
));
1324 strout (buf
, -1, printcharfun
);
1325 strout (" in ", -1, printcharfun
);
1326 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
1331 case Lisp_Misc_Overlay
:
1332 strout ("#<overlay ", -1, printcharfun
);
1333 if (!(XMARKER (OVERLAY_START (obj
))->buffer
))
1334 strout ("in no buffer", -1, printcharfun
);
1337 sprintf (buf
, "from %d to %d in ",
1338 marker_position (OVERLAY_START (obj
)),
1339 marker_position (OVERLAY_END (obj
)));
1340 strout (buf
, -1, printcharfun
);
1341 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
1347 /* Remaining cases shouldn't happen in normal usage, but let's print
1348 them anyway for the benefit of the debugger. */
1349 case Lisp_Misc_Free
:
1350 strout ("#<misc free cell>", -1, printcharfun
);
1353 case Lisp_Misc_Intfwd
:
1354 sprintf (buf
, "#<intfwd to %d>", *XINTFWD (obj
)->intvar
);
1355 strout (buf
, -1, printcharfun
);
1358 case Lisp_Misc_Boolfwd
:
1359 sprintf (buf
, "#<boolfwd to %s>",
1360 (*XBOOLFWD (obj
)->boolvar
? "t" : "nil"));
1361 strout (buf
, -1, printcharfun
);
1364 case Lisp_Misc_Objfwd
:
1365 strout ("#<objfwd to ", -1, printcharfun
);
1366 print (*XOBJFWD (obj
)->objvar
, printcharfun
, escapeflag
);
1370 case Lisp_Misc_Buffer_Objfwd
:
1371 strout ("#<buffer_objfwd to ", -1, printcharfun
);
1372 print (*(Lisp_Object
*)((char *)current_buffer
1373 + XBUFFER_OBJFWD (obj
)->offset
),
1374 printcharfun
, escapeflag
);
1378 case Lisp_Misc_Kboard_Objfwd
:
1379 strout ("#<kboard_objfwd to ", -1, printcharfun
);
1380 print (*(Lisp_Object
*)((char *) current_kboard
1381 + XKBOARD_OBJFWD (obj
)->offset
),
1382 printcharfun
, escapeflag
);
1386 case Lisp_Misc_Buffer_Local_Value
:
1387 strout ("#<buffer_local_value ", -1, printcharfun
);
1388 goto do_buffer_local
;
1389 case Lisp_Misc_Some_Buffer_Local_Value
:
1390 strout ("#<some_buffer_local_value ", -1, printcharfun
);
1392 strout ("[realvalue] ", -1, printcharfun
);
1393 print (XBUFFER_LOCAL_VALUE (obj
)->car
, printcharfun
, escapeflag
);
1394 strout ("[buffer] ", -1, printcharfun
);
1395 print (XCONS (XBUFFER_LOCAL_VALUE (obj
)->cdr
)->car
,
1396 printcharfun
, escapeflag
);
1397 strout ("[alist-elt] ", -1, printcharfun
);
1398 print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj
)->cdr
)->cdr
)->car
,
1399 printcharfun
, escapeflag
);
1400 strout ("[default-value] ", -1, printcharfun
);
1401 print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj
)->cdr
)->cdr
)->cdr
,
1402 printcharfun
, escapeflag
);
1410 #endif /* standalone */
1415 /* We're in trouble if this happens!
1416 Probably should just abort () */
1417 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, printcharfun
);
1419 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
1420 else if (VECTORLIKEP (obj
))
1421 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
1423 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
1424 strout (buf
, -1, printcharfun
);
1425 strout (" Save your buffers immediately and please report this bug>",
1433 #ifdef USE_TEXT_PROPERTIES
1435 /* Print a description of INTERVAL using PRINTCHARFUN.
1436 This is part of printing a string that has text properties. */
1439 print_interval (interval
, printcharfun
)
1441 Lisp_Object printcharfun
;
1444 print (make_number (interval
->position
), printcharfun
, 1);
1446 print (make_number (interval
->position
+ LENGTH (interval
)),
1449 print (interval
->plist
, printcharfun
, 1);
1452 #endif /* USE_TEXT_PROPERTIES */
1457 DEFVAR_LISP ("standard-output", &Vstandard_output
,
1458 "Output stream `print' uses by default for outputting a character.\n\
1459 This may be any function of one argument.\n\
1460 It may also be a buffer (output is inserted before point)\n\
1461 or a marker (output is inserted and the marker is advanced)\n\
1462 or the symbol t (output appears in the echo area).");
1463 Vstandard_output
= Qt
;
1464 Qstandard_output
= intern ("standard-output");
1465 staticpro (&Qstandard_output
);
1467 #ifdef LISP_FLOAT_TYPE
1468 DEFVAR_LISP ("float-output-format", &Vfloat_output_format
,
1469 "The format descriptor string used to print floats.\n\
1470 This is a %-spec like those accepted by `printf' in C,\n\
1471 but with some restrictions. It must start with the two characters `%.'.\n\
1472 After that comes an integer precision specification,\n\
1473 and then a letter which controls the format.\n\
1474 The letters allowed are `e', `f' and `g'.\n\
1475 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"\n\
1476 Use `f' for decimal point notation \"DIGITS.DIGITS\".\n\
1477 Use `g' to choose the shorter of those two formats for the number at hand.\n\
1478 The precision in any of these cases is the number of digits following\n\
1479 the decimal point. With `f', a precision of 0 means to omit the\n\
1480 decimal point. 0 is not allowed with `e' or `g'.\n\n\
1481 A value of nil means to use `%.17g'.");
1482 Vfloat_output_format
= Qnil
;
1483 Qfloat_output_format
= intern ("float-output-format");
1484 staticpro (&Qfloat_output_format
);
1485 #endif /* LISP_FLOAT_TYPE */
1487 DEFVAR_LISP ("print-length", &Vprint_length
,
1488 "Maximum length of list to print before abbreviating.\n\
1489 A value of nil means no limit.");
1490 Vprint_length
= Qnil
;
1492 DEFVAR_LISP ("print-level", &Vprint_level
,
1493 "Maximum depth of list nesting to print before abbreviating.\n\
1494 A value of nil means no limit.");
1495 Vprint_level
= Qnil
;
1497 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines
,
1498 "Non-nil means print newlines in strings as backslash-n.\n\
1499 Also print formfeeds as backslash-f.");
1500 print_escape_newlines
= 0;
1502 DEFVAR_BOOL ("print-quoted", &print_quoted
,
1503 "Non-nil means print quoted forms with reader syntax.\n\
1504 I.e., (quote foo) prints as 'foo, (function foo) as #'foo, and, backquoted\n\
1505 forms print in the new syntax.");
1508 DEFVAR_BOOL ("print-gensym", &print_gensym
,
1509 "Non-nil means print uninterned symbols so they will read as uninterned.\n\
1510 I.e., the value of (make-symbol "foobar
") prints as #:foobar.");
1513 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
1514 staticpro (&Vprin1_to_string_buffer
);
1517 defsubr (&Sprin1_to_string
);
1518 defsubr (&Serror_message_string
);
1522 defsubr (&Swrite_char
);
1523 defsubr (&Sexternal_debugging_output
);
1525 Qexternal_debugging_output
= intern ("external-debugging-output");
1526 staticpro (&Qexternal_debugging_output
);
1528 Qprint_escape_newlines
= intern ("print-escape-newlines");
1529 staticpro (&Qprint_escape_newlines
);
1531 staticpro (&printed_gensyms
);
1532 printed_gensyms
= Qnil
;
1535 defsubr (&Swith_output_to_temp_buffer
);
1536 #endif /* not standalone */