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 print_error_message (obj
, Vprin1_to_string_buffer
, NULL
);
732 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
733 value
= Fbuffer_string ();
737 set_buffer_internal (old
);
743 /* Print an error message for the error DATA
744 onto Lisp output stream STREAM (suitable for the print functions). */
746 print_error_message (data
, stream
)
747 Lisp_Object data
, stream
;
749 Lisp_Object errname
, errmsg
, file_error
, tail
;
753 errname
= Fcar (data
);
755 if (EQ (errname
, Qerror
))
758 if (!CONSP (data
)) data
= Qnil
;
759 errmsg
= Fcar (data
);
764 errmsg
= Fget (errname
, Qerror_message
);
765 file_error
= Fmemq (Qfile_error
,
766 Fget (errname
, Qerror_conditions
));
769 /* Print an error message including the data items. */
771 tail
= Fcdr_safe (data
);
774 /* For file-error, make error message by concatenating
775 all the data items. They are all strings. */
776 if (!NILP (file_error
) && !NILP (tail
))
777 errmsg
= XCONS (tail
)->car
, tail
= XCONS (tail
)->cdr
;
779 if (STRINGP (errmsg
))
780 Fprinc (errmsg
, stream
);
782 write_string_1 ("peculiar error", -1, stream
);
784 for (i
= 0; CONSP (tail
); tail
= Fcdr (tail
), i
++)
786 write_string_1 (i
? ", " : ": ", 2, stream
);
787 if (!NILP (file_error
))
788 Fprinc (Fcar (tail
), stream
);
790 Fprin1 (Fcar (tail
), stream
);
795 #ifdef LISP_FLOAT_TYPE
798 * The buffer should be at least as large as the max string size of the
799 * largest float, printed in the biggest notation. This is undoubtedly
800 * 20d float_output_format, with the negative of the C-constant "HUGE"
803 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
805 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
806 * case of -1e307 in 20d float_output_format. What is one to do (short of
807 * re-writing _doprnt to be more sane)?
812 float_to_string (buf
, data
)
819 if (NILP (Vfloat_output_format
)
820 || !STRINGP (Vfloat_output_format
))
823 sprintf (buf
, "%.17g", data
);
828 /* Check that the spec we have is fully valid.
829 This means not only valid for printf,
830 but meant for floats, and reasonable. */
831 cp
= XSTRING (Vfloat_output_format
)->data
;
840 /* Check the width specification. */
842 if ('0' <= *cp
&& *cp
<= '9')
846 width
= (width
* 10) + (*cp
++ - '0');
847 while (*cp
>= '0' && *cp
<= '9');
849 /* A precision of zero is valid only for %f. */
851 || (width
== 0 && *cp
!= 'f'))
855 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
861 sprintf (buf
, XSTRING (Vfloat_output_format
)->data
, data
);
864 /* Make sure there is a decimal point with digit after, or an
865 exponent, so that the value is readable as a float. But don't do
866 this with "%.0f"; it's valid for that not to produce a decimal
867 point. Note that width can be 0 only for %.0f. */
870 for (cp
= buf
; *cp
; cp
++)
871 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
874 if (*cp
== '.' && cp
[1] == 0)
888 #endif /* LISP_FLOAT_TYPE */
891 print (obj
, printcharfun
, escapeflag
)
893 register Lisp_Object printcharfun
;
900 #if 1 /* I'm not sure this is really worth doing. */
901 /* Detect circularities and truncate them.
902 No need to offer any alternative--this is better than an error. */
903 if (CONSP (obj
) || VECTORP (obj
) || COMPILEDP (obj
))
906 for (i
= 0; i
< print_depth
; i
++)
907 if (EQ (obj
, being_printed
[i
]))
909 sprintf (buf
, "#%d", i
);
910 strout (buf
, -1, printcharfun
);
916 being_printed
[print_depth
] = obj
;
919 if (print_depth
> PRINT_CIRCLE
)
920 error ("Apparently circular structure being printed");
921 #ifdef MAX_PRINT_CHARS
922 if (max_print
&& print_chars
> max_print
)
927 #endif /* MAX_PRINT_CHARS */
929 switch (XGCTYPE (obj
))
932 if (sizeof (int) == sizeof (EMACS_INT
))
933 sprintf (buf
, "%d", XINT (obj
));
934 else if (sizeof (long) == sizeof (EMACS_INT
))
935 sprintf (buf
, "%ld", XINT (obj
));
938 strout (buf
, -1, printcharfun
);
941 #ifdef LISP_FLOAT_TYPE
944 char pigbuf
[350]; /* see comments in float_to_string */
946 float_to_string (pigbuf
, XFLOAT(obj
)->data
);
947 strout (pigbuf
, -1, printcharfun
);
954 print_string (obj
, printcharfun
);
958 register unsigned char c
;
963 #ifdef USE_TEXT_PROPERTIES
964 if (!NULL_INTERVAL_P (XSTRING (obj
)->intervals
))
972 for (i
= 0; i
< XSTRING (obj
)->size
; i
++)
975 c
= XSTRING (obj
)->data
[i
];
976 if (c
== '\n' && print_escape_newlines
)
981 else if (c
== '\f' && print_escape_newlines
)
988 if (c
== '\"' || c
== '\\')
995 #ifdef USE_TEXT_PROPERTIES
996 if (!NULL_INTERVAL_P (XSTRING (obj
)->intervals
))
998 traverse_intervals (XSTRING (obj
)->intervals
,
999 0, 0, print_interval
, printcharfun
);
1010 register int confusing
;
1011 register unsigned char *p
= XSYMBOL (obj
)->name
->data
;
1012 register unsigned char *end
= p
+ XSYMBOL (obj
)->name
->size
;
1013 register unsigned char c
;
1016 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1019 /* If symbol name begins with a digit, and ends with a digit,
1020 and contains nothing but digits and `e', it could be treated
1021 as a number. So set CONFUSING.
1023 Symbols that contain periods could also be taken as numbers,
1024 but periods are always escaped, so we don't have to worry
1026 else if (*p
>= '0' && *p
<= '9'
1027 && end
[-1] >= '0' && end
[-1] <= '9')
1029 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1030 /* Needed for \2e10. */
1033 confusing
= (end
== p
);
1038 /* If we print an uninterned symbol as part of a complex object and
1039 the flag print-gensym is non-nil, prefix it with #n= to read the
1040 object back with the #n# reader syntax later if needed. */
1041 if (print_gensym
&& NILP (XSYMBOL (obj
)->obarray
))
1043 if (print_depth
> 1)
1046 tem
= Fassq (obj
, printed_gensyms
);
1050 print (XCDR (tem
), printcharfun
, escapeflag
);
1056 if (CONSP (printed_gensyms
))
1057 XSETFASTINT (tem
, XCDR (XCAR (printed_gensyms
)) + 1);
1059 XSETFASTINT (tem
, 1);
1060 printed_gensyms
= Fcons (Fcons (obj
, tem
), printed_gensyms
);
1063 print (tem
, printcharfun
, escapeflag
);
1071 for (i
= 0; i
< XSYMBOL (obj
)->name
->size
; i
++)
1074 c
= XSYMBOL (obj
)->name
->data
[i
];
1078 if (c
== '\"' || c
== '\\' || c
== '\''
1079 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1080 || c
== ',' || c
=='.' || c
== '`'
1081 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1083 PRINTCHAR ('\\'), confusing
= 0;
1091 /* If deeper than spec'd depth, print placeholder. */
1092 if (INTEGERP (Vprint_level
)
1093 && print_depth
> XINT (Vprint_level
))
1094 strout ("...", -1, printcharfun
);
1095 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1096 && (EQ (XCAR (obj
), Qquote
)))
1099 print (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1101 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1102 && (EQ (XCAR (obj
), Qfunction
)))
1106 print (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1108 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1109 && ((EQ (XCAR (obj
), Qbackquote
)
1110 || EQ (XCAR (obj
), Qcomma
)
1111 || EQ (XCAR (obj
), Qcomma_at
)
1112 || EQ (XCAR (obj
), Qcomma_dot
))))
1114 print (XCAR (obj
), printcharfun
, 0);
1115 print (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1122 register int max
= 0;
1124 if (INTEGERP (Vprint_length
))
1125 max
= XINT (Vprint_length
);
1126 /* Could recognize circularities in cdrs here,
1127 but that would make printing of long lists quadratic.
1128 It's not worth doing. */
1135 strout ("...", 3, printcharfun
);
1138 print (XCAR (obj
), printcharfun
, escapeflag
);
1144 strout (" . ", 3, printcharfun
);
1145 print (obj
, printcharfun
, escapeflag
);
1151 case Lisp_Vectorlike
:
1156 strout ("#<process ", -1, printcharfun
);
1157 print_string (XPROCESS (obj
)->name
, printcharfun
);
1161 print_string (XPROCESS (obj
)->name
, printcharfun
);
1163 else if (BOOL_VECTOR_P (obj
))
1166 register unsigned char c
;
1167 struct gcpro gcpro1
;
1169 = (XBOOL_VECTOR (obj
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1175 sprintf (buf
, "%d", XBOOL_VECTOR (obj
)->size
);
1176 strout (buf
, -1, printcharfun
);
1179 /* Don't print more characters than the specified maximum. */
1180 if (INTEGERP (Vprint_length
)
1181 && XINT (Vprint_length
) < size_in_chars
)
1182 size_in_chars
= XINT (Vprint_length
);
1184 for (i
= 0; i
< size_in_chars
; i
++)
1187 c
= XBOOL_VECTOR (obj
)->data
[i
];
1188 if (c
== '\n' && print_escape_newlines
)
1193 else if (c
== '\f' && print_escape_newlines
)
1200 if (c
== '\"' || c
== '\\')
1209 else if (SUBRP (obj
))
1211 strout ("#<subr ", -1, printcharfun
);
1212 strout (XSUBR (obj
)->symbol_name
, -1, printcharfun
);
1216 else if (WINDOWP (obj
))
1218 strout ("#<window ", -1, printcharfun
);
1219 sprintf (buf
, "%d", XFASTINT (XWINDOW (obj
)->sequence_number
));
1220 strout (buf
, -1, printcharfun
);
1221 if (!NILP (XWINDOW (obj
)->buffer
))
1223 strout (" on ", -1, printcharfun
);
1224 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1228 else if (BUFFERP (obj
))
1230 if (NILP (XBUFFER (obj
)->name
))
1231 strout ("#<killed buffer>", -1, printcharfun
);
1232 else if (escapeflag
)
1234 strout ("#<buffer ", -1, printcharfun
);
1235 print_string (XBUFFER (obj
)->name
, printcharfun
);
1239 print_string (XBUFFER (obj
)->name
, printcharfun
);
1241 else if (WINDOW_CONFIGURATIONP (obj
))
1243 strout ("#<window-configuration>", -1, printcharfun
);
1245 else if (FRAMEP (obj
))
1247 strout ((FRAME_LIVE_P (XFRAME (obj
))
1248 ? "#<frame " : "#<dead frame "),
1250 print_string (XFRAME (obj
)->name
, printcharfun
);
1251 sprintf (buf
, " 0x%lx", (unsigned long) (XFRAME (obj
)));
1252 strout (buf
, -1, printcharfun
);
1255 #endif /* not standalone */
1258 int size
= XVECTOR (obj
)->size
;
1259 if (COMPILEDP (obj
))
1262 size
&= PSEUDOVECTOR_SIZE_MASK
;
1264 if (CHAR_TABLE_P (obj
))
1266 /* We print a char-table as if it were a vector,
1267 lumping the parent and default slots in with the
1268 character slots. But we add #^ as a prefix. */
1271 if (SUB_CHAR_TABLE_P (obj
))
1273 size
&= PSEUDOVECTOR_SIZE_MASK
;
1275 if (size
& PSEUDOVECTOR_FLAG
)
1281 register Lisp_Object tem
;
1283 /* Don't print more elements than the specified maximum. */
1284 if (INTEGERP (Vprint_length
)
1285 && XINT (Vprint_length
) < size
)
1286 size
= XINT (Vprint_length
);
1288 for (i
= 0; i
< size
; i
++)
1290 if (i
) PRINTCHAR (' ');
1291 tem
= XVECTOR (obj
)->contents
[i
];
1292 print (tem
, printcharfun
, escapeflag
);
1301 switch (XMISCTYPE (obj
))
1303 case Lisp_Misc_Marker
:
1304 strout ("#<marker ", -1, printcharfun
);
1306 /* Do you think this is necessary? */
1307 if (XMARKER (obj
)->insertion_type
!= 0)
1308 strout ("(before-insertion) ", -1, printcharfun
);
1310 if (!(XMARKER (obj
)->buffer
))
1311 strout ("in no buffer", -1, printcharfun
);
1314 sprintf (buf
, "at %d", marker_position (obj
));
1315 strout (buf
, -1, printcharfun
);
1316 strout (" in ", -1, printcharfun
);
1317 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
1322 case Lisp_Misc_Overlay
:
1323 strout ("#<overlay ", -1, printcharfun
);
1324 if (!(XMARKER (OVERLAY_START (obj
))->buffer
))
1325 strout ("in no buffer", -1, printcharfun
);
1328 sprintf (buf
, "from %d to %d in ",
1329 marker_position (OVERLAY_START (obj
)),
1330 marker_position (OVERLAY_END (obj
)));
1331 strout (buf
, -1, printcharfun
);
1332 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
1338 /* Remaining cases shouldn't happen in normal usage, but let's print
1339 them anyway for the benefit of the debugger. */
1340 case Lisp_Misc_Free
:
1341 strout ("#<misc free cell>", -1, printcharfun
);
1344 case Lisp_Misc_Intfwd
:
1345 sprintf (buf
, "#<intfwd to %d>", *XINTFWD (obj
)->intvar
);
1346 strout (buf
, -1, printcharfun
);
1349 case Lisp_Misc_Boolfwd
:
1350 sprintf (buf
, "#<boolfwd to %s>",
1351 (*XBOOLFWD (obj
)->boolvar
? "t" : "nil"));
1352 strout (buf
, -1, printcharfun
);
1355 case Lisp_Misc_Objfwd
:
1356 strout ("#<objfwd to ", -1, printcharfun
);
1357 print (*XOBJFWD (obj
)->objvar
, printcharfun
, escapeflag
);
1361 case Lisp_Misc_Buffer_Objfwd
:
1362 strout ("#<buffer_objfwd to ", -1, printcharfun
);
1363 print (*(Lisp_Object
*)((char *)current_buffer
1364 + XBUFFER_OBJFWD (obj
)->offset
),
1365 printcharfun
, escapeflag
);
1369 case Lisp_Misc_Kboard_Objfwd
:
1370 strout ("#<kboard_objfwd to ", -1, printcharfun
);
1371 print (*(Lisp_Object
*)((char *) current_kboard
1372 + XKBOARD_OBJFWD (obj
)->offset
),
1373 printcharfun
, escapeflag
);
1377 case Lisp_Misc_Buffer_Local_Value
:
1378 strout ("#<buffer_local_value ", -1, printcharfun
);
1379 goto do_buffer_local
;
1380 case Lisp_Misc_Some_Buffer_Local_Value
:
1381 strout ("#<some_buffer_local_value ", -1, printcharfun
);
1383 strout ("[realvalue] ", -1, printcharfun
);
1384 print (XBUFFER_LOCAL_VALUE (obj
)->car
, printcharfun
, escapeflag
);
1385 strout ("[buffer] ", -1, printcharfun
);
1386 print (XCONS (XBUFFER_LOCAL_VALUE (obj
)->cdr
)->car
,
1387 printcharfun
, escapeflag
);
1388 strout ("[alist-elt] ", -1, printcharfun
);
1389 print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj
)->cdr
)->cdr
)->car
,
1390 printcharfun
, escapeflag
);
1391 strout ("[default-value] ", -1, printcharfun
);
1392 print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj
)->cdr
)->cdr
)->cdr
,
1393 printcharfun
, escapeflag
);
1401 #endif /* standalone */
1406 /* We're in trouble if this happens!
1407 Probably should just abort () */
1408 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, printcharfun
);
1410 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
1411 else if (VECTORLIKEP (obj
))
1412 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
1414 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
1415 strout (buf
, -1, printcharfun
);
1416 strout (" Save your buffers immediately and please report this bug>",
1424 #ifdef USE_TEXT_PROPERTIES
1426 /* Print a description of INTERVAL using PRINTCHARFUN.
1427 This is part of printing a string that has text properties. */
1430 print_interval (interval
, printcharfun
)
1432 Lisp_Object printcharfun
;
1435 print (make_number (interval
->position
), printcharfun
, 1);
1437 print (make_number (interval
->position
+ LENGTH (interval
)),
1440 print (interval
->plist
, printcharfun
, 1);
1443 #endif /* USE_TEXT_PROPERTIES */
1448 DEFVAR_LISP ("standard-output", &Vstandard_output
,
1449 "Output stream `print' uses by default for outputting a character.\n\
1450 This may be any function of one argument.\n\
1451 It may also be a buffer (output is inserted before point)\n\
1452 or a marker (output is inserted and the marker is advanced)\n\
1453 or the symbol t (output appears in the echo area).");
1454 Vstandard_output
= Qt
;
1455 Qstandard_output
= intern ("standard-output");
1456 staticpro (&Qstandard_output
);
1458 #ifdef LISP_FLOAT_TYPE
1459 DEFVAR_LISP ("float-output-format", &Vfloat_output_format
,
1460 "The format descriptor string used to print floats.\n\
1461 This is a %-spec like those accepted by `printf' in C,\n\
1462 but with some restrictions. It must start with the two characters `%.'.\n\
1463 After that comes an integer precision specification,\n\
1464 and then a letter which controls the format.\n\
1465 The letters allowed are `e', `f' and `g'.\n\
1466 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"\n\
1467 Use `f' for decimal point notation \"DIGITS.DIGITS\".\n\
1468 Use `g' to choose the shorter of those two formats for the number at hand.\n\
1469 The precision in any of these cases is the number of digits following\n\
1470 the decimal point. With `f', a precision of 0 means to omit the\n\
1471 decimal point. 0 is not allowed with `e' or `g'.\n\n\
1472 A value of nil means to use `%.17g'.");
1473 Vfloat_output_format
= Qnil
;
1474 Qfloat_output_format
= intern ("float-output-format");
1475 staticpro (&Qfloat_output_format
);
1476 #endif /* LISP_FLOAT_TYPE */
1478 DEFVAR_LISP ("print-length", &Vprint_length
,
1479 "Maximum length of list to print before abbreviating.\n\
1480 A value of nil means no limit.");
1481 Vprint_length
= Qnil
;
1483 DEFVAR_LISP ("print-level", &Vprint_level
,
1484 "Maximum depth of list nesting to print before abbreviating.\n\
1485 A value of nil means no limit.");
1486 Vprint_level
= Qnil
;
1488 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines
,
1489 "Non-nil means print newlines in strings as backslash-n.\n\
1490 Also print formfeeds as backslash-f.");
1491 print_escape_newlines
= 0;
1493 DEFVAR_BOOL ("print-quoted", &print_quoted
,
1494 "Non-nil means print quoted forms with reader syntax.\n\
1495 I.e., (quote foo) prints as 'foo, (function foo) as #'foo, and, backquoted\n\
1496 forms print in the new syntax.");
1499 DEFVAR_BOOL ("print-gensym", &print_gensym
,
1500 "Non-nil means print uninterned symbols so they will read as uninterned.\n\
1501 I.e., the value of (make-symbol "foobar
") prints as #:foobar.");
1504 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
1505 staticpro (&Vprin1_to_string_buffer
);
1508 defsubr (&Sprin1_to_string
);
1509 defsubr (&Serror_message_string
);
1513 defsubr (&Swrite_char
);
1514 defsubr (&Sexternal_debugging_output
);
1516 Qexternal_debugging_output
= intern ("external-debugging-output");
1517 staticpro (&Qexternal_debugging_output
);
1519 Qprint_escape_newlines
= intern ("print-escape-newlines");
1520 staticpro (&Qprint_escape_newlines
);
1522 staticpro (&printed_gensyms
);
1523 printed_gensyms
= Qnil
;
1526 defsubr (&Swith_output_to_temp_buffer
);
1527 #endif /* not standalone */