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 /* These are used to print like we read. */
43 extern Lisp_Object Qbackquote
, Qcomma
, Qcomma_at
, Qcomma_dot
, Qfunction
;
45 #ifdef LISP_FLOAT_TYPE
46 Lisp_Object Vfloat_output_format
, Qfloat_output_format
;
47 #endif /* LISP_FLOAT_TYPE */
49 /* Avoid actual stack overflow in print. */
52 /* Detect most circularities to print finite output. */
53 #define PRINT_CIRCLE 200
54 Lisp_Object being_printed
[PRINT_CIRCLE
];
56 /* When printing into a buffer, first we put the text in this
57 block, then insert it all at once. */
60 /* Size allocated in print_buffer. */
61 int print_buffer_size
;
62 /* Size used in print_buffer. */
65 /* Maximum length of list to print in full; noninteger means
66 effectively infinity */
68 Lisp_Object Vprint_length
;
70 /* Maximum depth of list to print in full; noninteger means
71 effectively infinity. */
73 Lisp_Object Vprint_level
;
75 /* Nonzero means print newlines in strings as \n. */
77 int print_escape_newlines
;
79 Lisp_Object Qprint_escape_newlines
;
81 /* Nonzero means print (quote foo) forms as 'foo, etc. */
85 /* Nonzero means print #: before uninterned symbols. */
89 /* Association list of certain objects that are `eq' in the form being
90 printed and which should be `eq' when read back in, using the #n=object
91 and #n# reader forms. Each element has the form (object . n). */
93 Lisp_Object printed_gensyms
;
95 /* Nonzero means print newline to stdout before next minibuffer message.
98 extern int noninteractive_need_newline
;
100 #ifdef MAX_PRINT_CHARS
101 static int print_chars
;
102 static int max_print
;
103 #endif /* MAX_PRINT_CHARS */
105 void print_interval ();
108 /* Convert between chars and GLYPHs */
112 register GLYPH
*glyphs
;
122 str_to_glyph_cpy (str
, glyphs
)
126 register GLYPH
*gp
= glyphs
;
127 register char *cp
= str
;
134 str_to_glyph_ncpy (str
, glyphs
, n
)
139 register GLYPH
*gp
= glyphs
;
140 register char *cp
= str
;
147 glyph_to_str_cpy (glyphs
, str
)
151 register GLYPH
*gp
= glyphs
;
152 register char *cp
= str
;
155 *str
++ = *gp
++ & 0377;
159 /* Low level output routines for characters and strings */
161 /* Lisp functions to do output using a stream
162 must have the stream in a variable called printcharfun
163 and must start with PRINTPREPARE, end with PRINTFINISH,
164 and use PRINTDECLARE to declare common variables.
165 Use PRINTCHAR to output one character,
166 or call strout to output a block of characters.
169 #define PRINTDECLARE \
170 struct buffer *old = current_buffer; \
171 int old_point = -1, start_point; \
174 #define PRINTPREPARE \
175 original = printcharfun; \
176 if (NILP (printcharfun)) printcharfun = Qt; \
177 if (BUFFERP (printcharfun)) \
178 { if (XBUFFER (printcharfun) != current_buffer) \
179 Fset_buffer (printcharfun); \
180 printcharfun = Qnil;} \
181 if (MARKERP (printcharfun)) \
182 { if (!(XMARKER (original)->buffer)) \
183 error ("Marker does not point anywhere"); \
184 if (XMARKER (original)->buffer != current_buffer) \
185 set_buffer_internal (XMARKER (original)->buffer); \
187 SET_PT (marker_position (printcharfun)); \
189 printcharfun = Qnil;} \
190 if (NILP (printcharfun)) \
192 print_buffer_pos = 0; \
193 print_buffer_size = 1000; \
194 print_buffer = (char *) xmalloc (print_buffer_size); \
198 printed_gensyms = Qnil
200 #define PRINTFINISH \
201 if (NILP (printcharfun)) \
202 insert (print_buffer, print_buffer_pos); \
203 if (print_buffer) free (print_buffer); \
204 if (MARKERP (original)) \
205 Fset_marker (original, make_number (PT), Qnil); \
206 if (old_point >= 0) \
207 SET_PT (old_point + (old_point >= start_point \
208 ? PT - start_point : 0)); \
209 if (old != current_buffer) \
210 set_buffer_internal (old); \
211 printed_gensyms = Qnil
213 #define PRINTCHAR(ch) printchar (ch, printcharfun)
215 /* Index of first unused element of FRAME_MESSAGE_BUF(mini_frame). */
216 static int printbufidx
;
225 #ifdef MAX_PRINT_CHARS
228 #endif /* MAX_PRINT_CHARS */
233 if (print_buffer_pos
== print_buffer_size
)
234 print_buffer
= (char *) xrealloc (print_buffer
,
235 print_buffer_size
*= 2);
236 print_buffer
[print_buffer_pos
++] = ch
;
243 = XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window
)));
248 noninteractive_need_newline
= 1;
252 if (echo_area_glyphs
!= FRAME_MESSAGE_BUF (mini_frame
)
253 || !message_buf_print
)
255 message_log_maybe_newline ();
256 echo_area_glyphs
= FRAME_MESSAGE_BUF (mini_frame
);
258 echo_area_glyphs_length
= 0;
259 message_buf_print
= 1;
262 message_dolog (&ch
, 1, 0);
263 if (printbufidx
< FRAME_WIDTH (mini_frame
) - 1)
264 FRAME_MESSAGE_BUF (mini_frame
)[printbufidx
++] = ch
;
265 FRAME_MESSAGE_BUF (mini_frame
)[printbufidx
] = 0;
266 echo_area_glyphs_length
= printbufidx
;
270 #endif /* not standalone */
272 XSETFASTINT (ch1
, ch
);
277 strout (ptr
, size
, printcharfun
)
280 Lisp_Object printcharfun
;
284 if (EQ (printcharfun
, Qnil
))
289 if (print_buffer_pos
+ size
> print_buffer_size
)
291 print_buffer_size
= print_buffer_size
* 2 + size
;
292 print_buffer
= (char *) xrealloc (print_buffer
,
295 bcopy (ptr
, print_buffer
+ print_buffer_pos
, size
);
296 print_buffer_pos
+= size
;
298 #ifdef MAX_PRINT_CHARS
301 #endif /* MAX_PRINT_CHARS */
304 if (EQ (printcharfun
, Qt
))
307 = XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window
)));
309 i
= size
>= 0 ? size
: strlen (ptr
);
310 #ifdef MAX_PRINT_CHARS
313 #endif /* MAX_PRINT_CHARS */
317 fwrite (ptr
, 1, i
, stdout
);
318 noninteractive_need_newline
= 1;
322 if (echo_area_glyphs
!= FRAME_MESSAGE_BUF (mini_frame
)
323 || !message_buf_print
)
325 message_log_maybe_newline ();
326 echo_area_glyphs
= FRAME_MESSAGE_BUF (mini_frame
);
328 echo_area_glyphs_length
= 0;
329 message_buf_print
= 1;
332 message_dolog (ptr
, i
, 0);
333 if (i
> FRAME_WIDTH (mini_frame
) - printbufidx
- 1)
334 i
= FRAME_WIDTH (mini_frame
) - printbufidx
- 1;
335 bcopy (ptr
, &FRAME_MESSAGE_BUF (mini_frame
) [printbufidx
], i
);
337 echo_area_glyphs_length
= printbufidx
;
338 FRAME_MESSAGE_BUF (mini_frame
) [printbufidx
] = 0;
345 PRINTCHAR (ptr
[i
++]);
348 PRINTCHAR (ptr
[i
++]);
351 /* Print the contents of a string STRING using PRINTCHARFUN.
352 It isn't safe to use strout in many cases,
353 because printing one char can relocate. */
355 print_string (string
, printcharfun
)
357 Lisp_Object printcharfun
;
359 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
360 /* strout is safe for output to a frame (echo area) or to print_buffer. */
361 strout (XSTRING (string
)->data
, XSTRING (string
)->size
, printcharfun
);
364 /* Otherwise, fetch the string address for each character. */
366 int size
= XSTRING (string
)->size
;
369 for (i
= 0; i
< size
; i
++)
370 PRINTCHAR (XSTRING (string
)->data
[i
]);
375 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
376 "Output character CHARACTER to stream PRINTCHARFUN.\n\
377 PRINTCHARFUN defaults to the value of `standard-output' (which see).")
378 (character
, printcharfun
)
379 Lisp_Object character
, printcharfun
;
383 if (NILP (printcharfun
))
384 printcharfun
= Vstandard_output
;
385 CHECK_NUMBER (character
, 0);
387 PRINTCHAR (XINT (character
));
392 /* Used from outside of print.c to print a block of SIZE chars at DATA
393 on the default output stream.
394 Do not use this on the contents of a Lisp string. */
396 write_string (data
, size
)
401 Lisp_Object printcharfun
;
403 printcharfun
= Vstandard_output
;
406 strout (data
, size
, printcharfun
);
410 /* Used from outside of print.c to print a block of SIZE chars at DATA
411 on a specified stream PRINTCHARFUN.
412 Do not use this on the contents of a Lisp string. */
414 write_string_1 (data
, size
, printcharfun
)
417 Lisp_Object printcharfun
;
422 strout (data
, size
, printcharfun
);
430 temp_output_buffer_setup (bufname
)
433 register struct buffer
*old
= current_buffer
;
434 register Lisp_Object buf
;
436 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
438 current_buffer
->directory
= old
->directory
;
439 current_buffer
->read_only
= Qnil
;
442 XSETBUFFER (buf
, current_buffer
);
443 specbind (Qstandard_output
, buf
);
445 set_buffer_internal (old
);
449 internal_with_output_to_temp_buffer (bufname
, function
, args
)
451 Lisp_Object (*function
) ();
454 int count
= specpdl_ptr
- specpdl
;
455 Lisp_Object buf
, val
;
459 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
460 temp_output_buffer_setup (bufname
);
461 buf
= Vstandard_output
;
464 val
= (*function
) (args
);
467 temp_output_buffer_show (buf
);
470 return unbind_to (count
, val
);
473 DEFUN ("with-output-to-temp-buffer", Fwith_output_to_temp_buffer
, Swith_output_to_temp_buffer
,
475 "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.\n\
476 The buffer is cleared out initially, and marked as unmodified when done.\n\
477 All output done by BODY is inserted in that buffer by default.\n\
478 The buffer is displayed in another window, but not selected.\n\
479 The value of the last form in BODY is returned.\n\
480 If BODY does not finish normally, the buffer BUFNAME is not displayed.\n\n\
481 If variable `temp-buffer-show-function' is non-nil, call it at the end\n\
482 to get the buffer displayed. It gets one argument, the buffer to display.")
488 int count
= specpdl_ptr
- specpdl
;
489 Lisp_Object buf
, val
;
492 name
= Feval (Fcar (args
));
495 CHECK_STRING (name
, 0);
496 temp_output_buffer_setup (XSTRING (name
)->data
);
497 buf
= Vstandard_output
;
499 val
= Fprogn (Fcdr (args
));
501 temp_output_buffer_show (buf
);
503 return unbind_to (count
, val
);
505 #endif /* not standalone */
507 static void print ();
509 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
510 "Output a newline to stream PRINTCHARFUN.\n\
511 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used.")
513 Lisp_Object printcharfun
;
517 if (NILP (printcharfun
))
518 printcharfun
= Vstandard_output
;
525 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
526 "Output the printed representation of OBJECT, any Lisp object.\n\
527 Quoting characters are printed when needed to make output that `read'\n\
528 can handle, whenever this is possible.\n\
529 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
530 (object
, printcharfun
)
531 Lisp_Object object
, printcharfun
;
535 #ifdef MAX_PRINT_CHARS
537 #endif /* MAX_PRINT_CHARS */
538 if (NILP (printcharfun
))
539 printcharfun
= Vstandard_output
;
542 print (object
, printcharfun
, 1);
547 /* a buffer which is used to hold output being built by prin1-to-string */
548 Lisp_Object Vprin1_to_string_buffer
;
550 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
551 "Return a string containing the printed representation of OBJECT,\n\
552 any Lisp object. Quoting characters are used when needed to make output\n\
553 that `read' can handle, whenever this is possible, unless the optional\n\
554 second argument NOESCAPE is non-nil.")
556 Lisp_Object object
, noescape
;
559 Lisp_Object printcharfun
;
560 struct gcpro gcpro1
, gcpro2
;
563 /* Save and restore this--we are altering a buffer
564 but we don't want to deactivate the mark just for that.
565 No need for specbind, since errors deactivate the mark. */
566 tem
= Vdeactivate_mark
;
567 GCPRO2 (object
, tem
);
569 printcharfun
= Vprin1_to_string_buffer
;
572 print (object
, printcharfun
, NILP (noescape
));
573 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
575 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
576 object
= Fbuffer_string ();
579 set_buffer_internal (old
);
581 Vdeactivate_mark
= tem
;
587 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
588 "Output the printed representation of OBJECT, any Lisp object.\n\
589 No quoting characters are used; no delimiters are printed around\n\
590 the contents of strings.\n\
591 Output stream is PRINTCHARFUN, or value of standard-output (which see).")
592 (object
, printcharfun
)
593 Lisp_Object object
, printcharfun
;
597 if (NILP (printcharfun
))
598 printcharfun
= Vstandard_output
;
601 print (object
, printcharfun
, 0);
606 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
607 "Output the printed representation of OBJECT, with newlines around it.\n\
608 Quoting characters are printed when needed to make output that `read'\n\
609 can handle, whenever this is possible.\n\
610 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
611 (object
, printcharfun
)
612 Lisp_Object object
, printcharfun
;
617 #ifdef MAX_PRINT_CHARS
619 max_print
= MAX_PRINT_CHARS
;
620 #endif /* MAX_PRINT_CHARS */
621 if (NILP (printcharfun
))
622 printcharfun
= Vstandard_output
;
627 print (object
, printcharfun
, 1);
630 #ifdef MAX_PRINT_CHARS
633 #endif /* MAX_PRINT_CHARS */
638 /* The subroutine object for external-debugging-output is kept here
639 for the convenience of the debugger. */
640 Lisp_Object Qexternal_debugging_output
;
642 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
643 "Write CHARACTER to stderr.\n\
644 You can call print while debugging emacs, and pass it this function\n\
645 to make it write to the debugging output.\n")
647 Lisp_Object character
;
649 CHECK_NUMBER (character
, 0);
650 putc (XINT (character
), stderr
);
655 /* This is the interface for debugging printing. */
661 Fprin1 (arg
, Qexternal_debugging_output
);
662 fprintf (stderr
, "\r\n");
665 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
667 "Convert an error value (ERROR-SYMBOL . DATA) to an error message.")
671 struct buffer
*old
= current_buffer
;
672 Lisp_Object original
, printcharfun
, value
;
675 print_error_message (obj
, Vprin1_to_string_buffer
, NULL
);
677 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
678 value
= Fbuffer_string ();
682 set_buffer_internal (old
);
688 /* Print an error message for the error DATA
689 onto Lisp output stream STREAM (suitable for the print functions). */
691 print_error_message (data
, stream
)
692 Lisp_Object data
, stream
;
694 Lisp_Object errname
, errmsg
, file_error
, tail
;
698 errname
= Fcar (data
);
700 if (EQ (errname
, Qerror
))
703 if (!CONSP (data
)) data
= Qnil
;
704 errmsg
= Fcar (data
);
709 errmsg
= Fget (errname
, Qerror_message
);
710 file_error
= Fmemq (Qfile_error
,
711 Fget (errname
, Qerror_conditions
));
714 /* Print an error message including the data items. */
716 tail
= Fcdr_safe (data
);
719 /* For file-error, make error message by concatenating
720 all the data items. They are all strings. */
721 if (!NILP (file_error
) && !NILP (tail
))
722 errmsg
= XCONS (tail
)->car
, tail
= XCONS (tail
)->cdr
;
724 if (STRINGP (errmsg
))
725 Fprinc (errmsg
, stream
);
727 write_string_1 ("peculiar error", -1, stream
);
729 for (i
= 0; CONSP (tail
); tail
= Fcdr (tail
), i
++)
731 write_string_1 (i
? ", " : ": ", 2, stream
);
732 if (!NILP (file_error
))
733 Fprinc (Fcar (tail
), stream
);
735 Fprin1 (Fcar (tail
), stream
);
740 #ifdef LISP_FLOAT_TYPE
743 * The buffer should be at least as large as the max string size of the
744 * largest float, printed in the biggest notation. This is undoubtedly
745 * 20d float_output_format, with the negative of the C-constant "HUGE"
748 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
750 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
751 * case of -1e307 in 20d float_output_format. What is one to do (short of
752 * re-writing _doprnt to be more sane)?
757 float_to_string (buf
, data
)
764 if (NILP (Vfloat_output_format
)
765 || !STRINGP (Vfloat_output_format
))
768 sprintf (buf
, "%.17g", data
);
773 /* Check that the spec we have is fully valid.
774 This means not only valid for printf,
775 but meant for floats, and reasonable. */
776 cp
= XSTRING (Vfloat_output_format
)->data
;
785 /* Check the width specification. */
787 if ('0' <= *cp
&& *cp
<= '9')
791 width
= (width
* 10) + (*cp
++ - '0');
792 while (*cp
>= '0' && *cp
<= '9');
794 /* A precision of zero is valid only for %f. */
796 || (width
== 0 && *cp
!= 'f'))
800 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
806 sprintf (buf
, XSTRING (Vfloat_output_format
)->data
, data
);
809 /* Make sure there is a decimal point with digit after, or an
810 exponent, so that the value is readable as a float. But don't do
811 this with "%.0f"; it's valid for that not to produce a decimal
812 point. Note that width can be 0 only for %.0f. */
815 for (cp
= buf
; *cp
; cp
++)
816 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
819 if (*cp
== '.' && cp
[1] == 0)
833 #endif /* LISP_FLOAT_TYPE */
836 print (obj
, printcharfun
, escapeflag
)
838 register Lisp_Object printcharfun
;
845 #if 1 /* I'm not sure this is really worth doing. */
846 /* Detect circularities and truncate them.
847 No need to offer any alternative--this is better than an error. */
848 if (CONSP (obj
) || VECTORP (obj
) || COMPILEDP (obj
))
851 for (i
= 0; i
< print_depth
; i
++)
852 if (EQ (obj
, being_printed
[i
]))
854 sprintf (buf
, "#%d", i
);
855 strout (buf
, -1, printcharfun
);
861 being_printed
[print_depth
] = obj
;
864 if (print_depth
> PRINT_CIRCLE
)
865 error ("Apparently circular structure being printed");
866 #ifdef MAX_PRINT_CHARS
867 if (max_print
&& print_chars
> max_print
)
872 #endif /* MAX_PRINT_CHARS */
874 switch (XGCTYPE (obj
))
877 if (sizeof (int) == sizeof (EMACS_INT
))
878 sprintf (buf
, "%d", XINT (obj
));
879 else if (sizeof (long) == sizeof (EMACS_INT
))
880 sprintf (buf
, "%ld", XINT (obj
));
883 strout (buf
, -1, printcharfun
);
886 #ifdef LISP_FLOAT_TYPE
889 char pigbuf
[350]; /* see comments in float_to_string */
891 float_to_string (pigbuf
, XFLOAT(obj
)->data
);
892 strout (pigbuf
, -1, printcharfun
);
899 print_string (obj
, printcharfun
);
903 register unsigned char c
;
908 #ifdef USE_TEXT_PROPERTIES
909 if (!NULL_INTERVAL_P (XSTRING (obj
)->intervals
))
917 for (i
= 0; i
< XSTRING (obj
)->size
; i
++)
920 c
= XSTRING (obj
)->data
[i
];
921 if (c
== '\n' && print_escape_newlines
)
926 else if (c
== '\f' && print_escape_newlines
)
933 if (c
== '\"' || c
== '\\')
940 #ifdef USE_TEXT_PROPERTIES
941 if (!NULL_INTERVAL_P (XSTRING (obj
)->intervals
))
943 traverse_intervals (XSTRING (obj
)->intervals
,
944 0, 0, print_interval
, printcharfun
);
955 register int confusing
;
956 register unsigned char *p
= XSYMBOL (obj
)->name
->data
;
957 register unsigned char *end
= p
+ XSYMBOL (obj
)->name
->size
;
958 register unsigned char c
;
960 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
965 while (p
!= end
&& *p
>= '0' && *p
<= '9')
967 confusing
= (end
== p
);
970 /* If we print an uninterned symbol as part of a complex object and
971 the flag print-gensym is non-nil, prefix it with #n= to read the
972 object back with the #n# reader syntax later if needed. */
973 if (print_gensym
&& NILP (XSYMBOL (obj
)->obarray
))
978 tem
= Fassq (obj
, printed_gensyms
);
982 print (XCDR (tem
), printcharfun
, escapeflag
);
988 if (CONSP (printed_gensyms
))
989 XSETFASTINT (tem
, XCDR (XCAR (printed_gensyms
)) + 1);
991 XSETFASTINT (tem
, 1);
992 printed_gensyms
= Fcons (Fcons (obj
, tem
), printed_gensyms
);
995 print (tem
, printcharfun
, escapeflag
);
1003 p
= XSYMBOL (obj
)->name
->data
;
1010 if (c
== '\"' || c
== '\\' || c
== '\'' || c
== ';' || c
== '#' ||
1011 c
== '(' || c
== ')' || c
== ',' || c
=='.' || c
== '`' ||
1012 c
== '[' || c
== ']' || c
== '?' || c
<= 040 || confusing
)
1013 PRINTCHAR ('\\'), confusing
= 0;
1021 /* If deeper than spec'd depth, print placeholder. */
1022 if (INTEGERP (Vprint_level
)
1023 && print_depth
> XINT (Vprint_level
))
1024 strout ("...", -1, printcharfun
);
1025 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1026 && (EQ (XCAR (obj
), Qquote
)))
1029 print (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1031 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1032 && (EQ (XCAR (obj
), Qfunction
)))
1036 print (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1038 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1039 && ((EQ (XCAR (obj
), Qbackquote
)
1040 || EQ (XCAR (obj
), Qcomma
)
1041 || EQ (XCAR (obj
), Qcomma_at
)
1042 || EQ (XCAR (obj
), Qcomma_dot
))))
1044 print (XCAR (obj
), printcharfun
, 0);
1045 print (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1052 register int max
= 0;
1054 if (INTEGERP (Vprint_length
))
1055 max
= XINT (Vprint_length
);
1056 /* Could recognize circularities in cdrs here,
1057 but that would make printing of long lists quadratic.
1058 It's not worth doing. */
1065 strout ("...", 3, printcharfun
);
1068 print (XCAR (obj
), printcharfun
, escapeflag
);
1074 strout (" . ", 3, printcharfun
);
1075 print (obj
, printcharfun
, escapeflag
);
1081 case Lisp_Vectorlike
:
1086 strout ("#<process ", -1, printcharfun
);
1087 print_string (XPROCESS (obj
)->name
, printcharfun
);
1091 print_string (XPROCESS (obj
)->name
, printcharfun
);
1093 else if (BOOL_VECTOR_P (obj
))
1096 register unsigned char c
;
1097 struct gcpro gcpro1
;
1099 = (XBOOL_VECTOR (obj
)->size
+ BITS_PER_CHAR
) / BITS_PER_CHAR
;
1105 sprintf (buf
, "%d", XBOOL_VECTOR (obj
)->size
);
1106 strout (buf
, -1, printcharfun
);
1109 /* Don't print more characters than the specified maximum. */
1110 if (INTEGERP (Vprint_length
)
1111 && XINT (Vprint_length
) < size_in_chars
)
1112 size_in_chars
= XINT (Vprint_length
);
1114 for (i
= 0; i
< size_in_chars
; i
++)
1117 c
= XBOOL_VECTOR (obj
)->data
[i
];
1118 if (c
== '\n' && print_escape_newlines
)
1123 else if (c
== '\f' && print_escape_newlines
)
1130 if (c
== '\"' || c
== '\\')
1139 else if (SUBRP (obj
))
1141 strout ("#<subr ", -1, printcharfun
);
1142 strout (XSUBR (obj
)->symbol_name
, -1, printcharfun
);
1146 else if (WINDOWP (obj
))
1148 strout ("#<window ", -1, printcharfun
);
1149 sprintf (buf
, "%d", XFASTINT (XWINDOW (obj
)->sequence_number
));
1150 strout (buf
, -1, printcharfun
);
1151 if (!NILP (XWINDOW (obj
)->buffer
))
1153 strout (" on ", -1, printcharfun
);
1154 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1158 else if (BUFFERP (obj
))
1160 if (NILP (XBUFFER (obj
)->name
))
1161 strout ("#<killed buffer>", -1, printcharfun
);
1162 else if (escapeflag
)
1164 strout ("#<buffer ", -1, printcharfun
);
1165 print_string (XBUFFER (obj
)->name
, printcharfun
);
1169 print_string (XBUFFER (obj
)->name
, printcharfun
);
1171 else if (WINDOW_CONFIGURATIONP (obj
))
1173 strout ("#<window-configuration>", -1, printcharfun
);
1175 else if (FRAMEP (obj
))
1177 strout ((FRAME_LIVE_P (XFRAME (obj
))
1178 ? "#<frame " : "#<dead frame "),
1180 print_string (XFRAME (obj
)->name
, printcharfun
);
1181 sprintf (buf
, " 0x%lx", (unsigned long) (XFRAME (obj
)));
1182 strout (buf
, -1, printcharfun
);
1185 #endif /* not standalone */
1188 int size
= XVECTOR (obj
)->size
;
1189 if (COMPILEDP (obj
))
1192 size
&= PSEUDOVECTOR_SIZE_MASK
;
1194 if (CHAR_TABLE_P (obj
))
1196 /* We print a char-table as if it were a vector,
1197 lumping the parent and default slots in with the
1198 character slots. But we add #^ as a prefix. */
1201 size
&= PSEUDOVECTOR_SIZE_MASK
;
1203 if (size
& PSEUDOVECTOR_FLAG
)
1209 register Lisp_Object tem
;
1211 /* Don't print more elements than the specified maximum. */
1212 if (INTEGERP (Vprint_length
)
1213 && XINT (Vprint_length
) < size
)
1214 size
= XINT (Vprint_length
);
1216 for (i
= 0; i
< size
; i
++)
1218 if (i
) PRINTCHAR (' ');
1219 tem
= XVECTOR (obj
)->contents
[i
];
1220 print (tem
, printcharfun
, escapeflag
);
1229 switch (XMISCTYPE (obj
))
1231 case Lisp_Misc_Marker
:
1232 strout ("#<marker ", -1, printcharfun
);
1233 if (!(XMARKER (obj
)->buffer
))
1234 strout ("in no buffer", -1, printcharfun
);
1237 sprintf (buf
, "at %d", marker_position (obj
));
1238 strout (buf
, -1, printcharfun
);
1239 strout (" in ", -1, printcharfun
);
1240 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
1245 case Lisp_Misc_Overlay
:
1246 strout ("#<overlay ", -1, printcharfun
);
1247 if (!(XMARKER (OVERLAY_START (obj
))->buffer
))
1248 strout ("in no buffer", -1, printcharfun
);
1251 sprintf (buf
, "from %d to %d in ",
1252 marker_position (OVERLAY_START (obj
)),
1253 marker_position (OVERLAY_END (obj
)));
1254 strout (buf
, -1, printcharfun
);
1255 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
1261 /* Remaining cases shouldn't happen in normal usage, but let's print
1262 them anyway for the benefit of the debugger. */
1263 case Lisp_Misc_Free
:
1264 strout ("#<misc free cell>", -1, printcharfun
);
1267 case Lisp_Misc_Intfwd
:
1268 sprintf (buf
, "#<intfwd to %d>", *XINTFWD (obj
)->intvar
);
1269 strout (buf
, -1, printcharfun
);
1272 case Lisp_Misc_Boolfwd
:
1273 sprintf (buf
, "#<boolfwd to %s>",
1274 (*XBOOLFWD (obj
)->boolvar
? "t" : "nil"));
1275 strout (buf
, -1, printcharfun
);
1278 case Lisp_Misc_Objfwd
:
1279 strout ("#<objfwd to ", -1, printcharfun
);
1280 print (*XOBJFWD (obj
)->objvar
, printcharfun
, escapeflag
);
1284 case Lisp_Misc_Buffer_Objfwd
:
1285 strout ("#<buffer_objfwd to ", -1, printcharfun
);
1286 print (*(Lisp_Object
*)((char *)current_buffer
1287 + XBUFFER_OBJFWD (obj
)->offset
),
1288 printcharfun
, escapeflag
);
1292 case Lisp_Misc_Kboard_Objfwd
:
1293 strout ("#<kboard_objfwd to ", -1, printcharfun
);
1294 print (*(Lisp_Object
*)((char *) current_kboard
1295 + XKBOARD_OBJFWD (obj
)->offset
),
1296 printcharfun
, escapeflag
);
1300 case Lisp_Misc_Buffer_Local_Value
:
1301 strout ("#<buffer_local_value ", -1, printcharfun
);
1302 goto do_buffer_local
;
1303 case Lisp_Misc_Some_Buffer_Local_Value
:
1304 strout ("#<some_buffer_local_value ", -1, printcharfun
);
1306 strout ("[realvalue] ", -1, printcharfun
);
1307 print (XBUFFER_LOCAL_VALUE (obj
)->car
, printcharfun
, escapeflag
);
1308 strout ("[buffer] ", -1, printcharfun
);
1309 print (XCONS (XBUFFER_LOCAL_VALUE (obj
)->cdr
)->car
,
1310 printcharfun
, escapeflag
);
1311 strout ("[alist-elt] ", -1, printcharfun
);
1312 print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj
)->cdr
)->cdr
)->car
,
1313 printcharfun
, escapeflag
);
1314 strout ("[default-value] ", -1, printcharfun
);
1315 print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj
)->cdr
)->cdr
)->cdr
,
1316 printcharfun
, escapeflag
);
1324 #endif /* standalone */
1329 /* We're in trouble if this happens!
1330 Probably should just abort () */
1331 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, printcharfun
);
1333 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
1334 else if (VECTORLIKEP (obj
))
1335 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
1337 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
1338 strout (buf
, -1, printcharfun
);
1339 strout (" Save your buffers immediately and please report this bug>",
1347 #ifdef USE_TEXT_PROPERTIES
1349 /* Print a description of INTERVAL using PRINTCHARFUN.
1350 This is part of printing a string that has text properties. */
1353 print_interval (interval
, printcharfun
)
1355 Lisp_Object printcharfun
;
1358 print (make_number (interval
->position
), printcharfun
, 1);
1360 print (make_number (interval
->position
+ LENGTH (interval
)),
1363 print (interval
->plist
, printcharfun
, 1);
1366 #endif /* USE_TEXT_PROPERTIES */
1371 DEFVAR_LISP ("standard-output", &Vstandard_output
,
1372 "Output stream `print' uses by default for outputting a character.\n\
1373 This may be any function of one argument.\n\
1374 It may also be a buffer (output is inserted before point)\n\
1375 or a marker (output is inserted and the marker is advanced)\n\
1376 or the symbol t (output appears in the echo area).");
1377 Vstandard_output
= Qt
;
1378 Qstandard_output
= intern ("standard-output");
1379 staticpro (&Qstandard_output
);
1381 #ifdef LISP_FLOAT_TYPE
1382 DEFVAR_LISP ("float-output-format", &Vfloat_output_format
,
1383 "The format descriptor string used to print floats.\n\
1384 This is a %-spec like those accepted by `printf' in C,\n\
1385 but with some restrictions. It must start with the two characters `%.'.\n\
1386 After that comes an integer precision specification,\n\
1387 and then a letter which controls the format.\n\
1388 The letters allowed are `e', `f' and `g'.\n\
1389 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"\n\
1390 Use `f' for decimal point notation \"DIGITS.DIGITS\".\n\
1391 Use `g' to choose the shorter of those two formats for the number at hand.\n\
1392 The precision in any of these cases is the number of digits following\n\
1393 the decimal point. With `f', a precision of 0 means to omit the\n\
1394 decimal point. 0 is not allowed with `e' or `g'.\n\n\
1395 A value of nil means to use `%.17g'.");
1396 Vfloat_output_format
= Qnil
;
1397 Qfloat_output_format
= intern ("float-output-format");
1398 staticpro (&Qfloat_output_format
);
1399 #endif /* LISP_FLOAT_TYPE */
1401 DEFVAR_LISP ("print-length", &Vprint_length
,
1402 "Maximum length of list to print before abbreviating.\n\
1403 A value of nil means no limit.");
1404 Vprint_length
= Qnil
;
1406 DEFVAR_LISP ("print-level", &Vprint_level
,
1407 "Maximum depth of list nesting to print before abbreviating.\n\
1408 A value of nil means no limit.");
1409 Vprint_level
= Qnil
;
1411 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines
,
1412 "Non-nil means print newlines in strings as backslash-n.\n\
1413 Also print formfeeds as backslash-f.");
1414 print_escape_newlines
= 0;
1416 DEFVAR_BOOL ("print-quoted", &print_quoted
,
1417 "Non-nil means print quoted forms with reader syntax.\n\
1418 I.e., (quote foo) prints as 'foo, (function foo) as #'foo, and, backquoted\n\
1419 forms print in the new syntax.");
1422 DEFVAR_BOOL ("print-gensym", &print_gensym
,
1423 "Non-nil means print uninterned symbols so they will read as uninterned.\n\
1424 I.e., the value of (make-symbol "foobar
") prints as #:foobar.");
1427 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
1428 staticpro (&Vprin1_to_string_buffer
);
1431 defsubr (&Sprin1_to_string
);
1432 defsubr (&Serror_message_string
);
1436 defsubr (&Swrite_char
);
1437 defsubr (&Sexternal_debugging_output
);
1439 Qexternal_debugging_output
= intern ("external-debugging-output");
1440 staticpro (&Qexternal_debugging_output
);
1442 Qprint_escape_newlines
= intern ("print-escape-newlines");
1443 staticpro (&Qprint_escape_newlines
);
1445 staticpro (&printed_gensyms
);
1446 printed_gensyms
= Qnil
;
1449 defsubr (&Swith_output_to_temp_buffer
);
1450 #endif /* not standalone */