1 /* Lisp object printing and output streams.
2 Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
31 #include "dispextern.h"
35 #ifdef USE_TEXT_PROPERTIES
36 #include "intervals.h"
39 Lisp_Object Vstandard_output
, Qstandard_output
;
41 Lisp_Object Qtemp_buffer_setup_hook
;
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
;
49 /* Work around a problem that happens because math.h on hpux 7
50 defines two static variables--which, in Emacs, are not really static,
51 because `static' is defined as nothing. The problem is that they are
52 defined both here and in lread.c.
53 These macros prevent the name conflict. */
54 #if defined (HPUX) && !defined (HPUX8)
55 #define _MAXLDBL print_maxldbl
56 #define _NMAXLDBL print_nmaxldbl
65 /* Default to values appropriate for IEEE floating point. */
70 #define DBL_MANT_DIG 53
76 #define DBL_MIN 2.2250738585072014e-308
79 #ifdef DBL_MIN_REPLACEMENT
81 #define DBL_MIN DBL_MIN_REPLACEMENT
84 /* Define DOUBLE_DIGITS_BOUND, an upper bound on the number of decimal digits
85 needed to express a float without losing information.
86 The general-case formula is valid for the usual case, IEEE floating point,
87 but many compilers can't optimize the formula to an integer constant,
88 so make a special case for it. */
89 #if FLT_RADIX == 2 && DBL_MANT_DIG == 53
90 #define DOUBLE_DIGITS_BOUND 17 /* IEEE floating point */
92 #define DOUBLE_DIGITS_BOUND ((int) ceil (log10 (pow (FLT_RADIX, DBL_MANT_DIG))))
95 #endif /* LISP_FLOAT_TYPE */
97 /* Avoid actual stack overflow in print. */
100 /* Detect most circularities to print finite output. */
101 #define PRINT_CIRCLE 200
102 Lisp_Object being_printed
[PRINT_CIRCLE
];
104 /* When printing into a buffer, first we put the text in this
105 block, then insert it all at once. */
108 /* Size allocated in print_buffer. */
109 int print_buffer_size
;
110 /* Chars stored in print_buffer. */
111 int print_buffer_pos
;
112 /* Bytes stored in print_buffer. */
113 int print_buffer_pos_byte
;
115 /* Maximum length of list to print in full; noninteger means
116 effectively infinity */
118 Lisp_Object Vprint_length
;
120 /* Maximum depth of list to print in full; noninteger means
121 effectively infinity. */
123 Lisp_Object Vprint_level
;
125 /* Nonzero means print newlines in strings as \n. */
127 int print_escape_newlines
;
129 /* Nonzero means to print single-byte non-ascii characters in strings as
132 int print_escape_nonascii
;
134 /* Nonzero means to print multibyte characters in strings as hex escapes. */
136 int print_escape_multibyte
;
138 Lisp_Object Qprint_escape_newlines
;
139 Lisp_Object Qprint_escape_multibyte
, Qprint_escape_nonascii
;
141 /* Nonzero means print (quote foo) forms as 'foo, etc. */
145 /* Non-nil means print #: before uninterned symbols. */
147 Lisp_Object Vprint_gensym
;
149 /* Non-nil means print recursive structures using #n= and #n# syntax. */
151 Lisp_Object Vprint_circle
;
153 /* Non-nil means keep continuous number for #n= and #n# syntax
154 between several print functions. */
156 Lisp_Object Vprint_continuous_numbering
;
158 /* Vprint_number_table is a vector like [OBJ1 STAT1 OBJ2 STAT2 ...],
159 where OBJn are objects going to be printed, and STATn are their status,
160 which may be different meanings during process. See the comments of
161 the functions print and print_preprocess for details.
162 print_number_index keeps the last position the next object should be added,
163 twice of which is the actual vector position in Vprint_number_table. */
164 int print_number_index
;
165 Lisp_Object Vprint_number_table
;
167 /* PRINT_NUMBER_OBJECT returns the I'th object in Vprint_number_table TABLE.
168 PRINT_NUMBER_STATUS returns the status of the I'th object in TABLE.
169 See the comment of the variable Vprint_number_table. */
170 #define PRINT_NUMBER_OBJECT(table,i) XVECTOR ((table))->contents[(i) * 2]
171 #define PRINT_NUMBER_STATUS(table,i) XVECTOR ((table))->contents[(i) * 2 + 1]
173 /* Nonzero means print newline to stdout before next minibuffer message.
174 Defined in xdisp.c */
176 extern int noninteractive_need_newline
;
178 extern int minibuffer_auto_raise
;
180 #ifdef MAX_PRINT_CHARS
181 static int print_chars
;
182 static int max_print
;
183 #endif /* MAX_PRINT_CHARS */
185 void print_interval ();
188 /* Low level output routines for characters and strings */
190 /* Lisp functions to do output using a stream
191 must have the stream in a variable called printcharfun
192 and must start with PRINTPREPARE, end with PRINTFINISH,
193 and use PRINTDECLARE to declare common variables.
194 Use PRINTCHAR to output one character,
195 or call strout to output a block of characters. */
197 #define PRINTDECLARE \
198 struct buffer *old = current_buffer; \
199 int old_point = -1, start_point; \
200 int old_point_byte, start_point_byte; \
201 int specpdl_count = specpdl_ptr - specpdl; \
202 int free_print_buffer = 0; \
203 int multibyte = !NILP (current_buffer->enable_multibyte_characters); \
206 #define PRINTPREPARE \
207 original = printcharfun; \
208 if (NILP (printcharfun)) printcharfun = Qt; \
209 if (BUFFERP (printcharfun)) \
211 if (XBUFFER (printcharfun) != current_buffer) \
212 Fset_buffer (printcharfun); \
213 printcharfun = Qnil; \
215 if (MARKERP (printcharfun)) \
217 if (!(XMARKER (original)->buffer)) \
218 error ("Marker does not point anywhere"); \
219 if (XMARKER (original)->buffer != current_buffer) \
220 set_buffer_internal (XMARKER (original)->buffer); \
222 old_point_byte = PT_BYTE; \
223 SET_PT_BOTH (marker_position (printcharfun), \
224 marker_byte_position (printcharfun)); \
226 start_point_byte = PT_BYTE; \
227 printcharfun = Qnil; \
229 if (NILP (printcharfun)) \
231 Lisp_Object string; \
232 if (NILP (current_buffer->enable_multibyte_characters) \
233 && ! print_escape_multibyte) \
234 specbind (Qprint_escape_multibyte, Qt); \
235 if (! NILP (current_buffer->enable_multibyte_characters) \
236 && ! print_escape_nonascii) \
237 specbind (Qprint_escape_nonascii, Qt); \
238 if (print_buffer != 0) \
240 string = make_string_from_bytes (print_buffer, \
242 print_buffer_pos_byte); \
243 record_unwind_protect (print_unwind, string); \
247 print_buffer_size = 1000; \
248 print_buffer = (char *) xmalloc (print_buffer_size); \
249 free_print_buffer = 1; \
251 print_buffer_pos = 0; \
252 print_buffer_pos_byte = 0; \
254 if (EQ (printcharfun, Qt)) \
255 setup_echo_area_for_printing (multibyte);
257 #define PRINTFINISH \
258 if (NILP (printcharfun)) \
260 if (print_buffer_pos != print_buffer_pos_byte \
261 && NILP (current_buffer->enable_multibyte_characters)) \
263 unsigned char *temp \
264 = (unsigned char *) alloca (print_buffer_pos + 1); \
265 copy_text (print_buffer, temp, print_buffer_pos_byte, \
267 insert_1_both (temp, print_buffer_pos, \
268 print_buffer_pos, 0, 1, 0); \
271 insert_1_both (print_buffer, print_buffer_pos, \
272 print_buffer_pos_byte, 0, 1, 0); \
274 if (free_print_buffer) \
276 xfree (print_buffer); \
279 unbind_to (specpdl_count, Qnil); \
280 if (MARKERP (original)) \
281 set_marker_both (original, Qnil, PT, PT_BYTE); \
282 if (old_point >= 0) \
283 SET_PT_BOTH (old_point + (old_point >= start_point \
284 ? PT - start_point : 0), \
285 old_point_byte + (old_point_byte >= start_point_byte \
286 ? PT_BYTE - start_point_byte : 0)); \
287 if (old != current_buffer) \
288 set_buffer_internal (old);
290 #define PRINTCHAR(ch) printchar (ch, printcharfun)
292 /* This is used to restore the saved contents of print_buffer
293 when there is a recursive call to print. */
296 print_unwind (saved_text
)
297 Lisp_Object saved_text
;
299 bcopy (XSTRING (saved_text
)->data
, print_buffer
, XSTRING (saved_text
)->size
);
303 /* Print character CH using method FUN. FUN nil means print to
304 print_buffer. FUN t means print to echo area or stdout if
305 non-interactive. If FUN is neither nil nor t, call FUN with CH as
313 #ifdef MAX_PRINT_CHARS
316 #endif /* MAX_PRINT_CHARS */
318 if (!NILP (fun
) && !EQ (fun
, Qt
))
319 call1 (fun
, make_number (ch
));
322 unsigned char work
[4], *str
;
323 int len
= CHAR_STRING (ch
, work
, str
);
329 if (print_buffer_pos_byte
+ len
>= print_buffer_size
)
330 print_buffer
= (char *) xrealloc (print_buffer
,
331 print_buffer_size
*= 2);
332 bcopy (str
, print_buffer
+ print_buffer_pos_byte
, len
);
333 print_buffer_pos
+= 1;
334 print_buffer_pos_byte
+= len
;
336 else if (noninteractive
)
338 fwrite (str
, 1, len
, stdout
);
339 noninteractive_need_newline
= 1;
344 = !NILP (current_buffer
->enable_multibyte_characters
);
346 if (!message_buf_print
)
347 setup_echo_area_for_printing (multibyte_p
);
350 message_dolog (str
, len
, 0, multibyte_p
);
356 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
357 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
358 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
359 print_buffer. PRINTCHARFUN t means output to the echo area or to
360 stdout if non-interactive. If neither nil nor t, call Lisp
361 function PRINTCHARFUN for each character printed. MULTIBYTE
362 non-zero means PTR contains multibyte characters. */
365 strout (ptr
, size
, size_byte
, printcharfun
, multibyte
)
368 Lisp_Object printcharfun
;
372 size_byte
= size
= strlen (ptr
);
374 if (NILP (printcharfun
))
376 if (print_buffer_pos_byte
+ size_byte
> print_buffer_size
)
378 print_buffer_size
= print_buffer_size
* 2 + size_byte
;
379 print_buffer
= (char *) xrealloc (print_buffer
,
382 bcopy (ptr
, print_buffer
+ print_buffer_pos_byte
, size_byte
);
383 print_buffer_pos
+= size
;
384 print_buffer_pos_byte
+= size_byte
;
386 #ifdef MAX_PRINT_CHARS
389 #endif /* MAX_PRINT_CHARS */
391 else if (noninteractive
)
393 fwrite (ptr
, 1, size_byte
, stdout
);
394 noninteractive_need_newline
= 1;
396 else if (EQ (printcharfun
, Qt
))
398 /* Output to echo area. We're trying to avoid a little overhead
399 here, that's the reason we don't call printchar to do the
403 = !NILP (current_buffer
->enable_multibyte_characters
);
405 if (!message_buf_print
)
406 setup_echo_area_for_printing (multibyte_p
);
408 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
410 if (size
== size_byte
)
412 for (i
= 0; i
< size
; ++i
)
413 insert_char (*ptr
++);
418 for (i
= 0; i
< size_byte
; i
+= len
)
420 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size_byte
- i
, len
);
425 #ifdef MAX_PRINT_CHARS
428 #endif /* MAX_PRINT_CHARS */
432 /* PRINTCHARFUN is a Lisp function. */
435 if (size
== size_byte
)
437 while (i
< size_byte
)
445 while (i
< size_byte
)
447 /* Here, we must convert each multi-byte form to the
448 corresponding character code before handing it to
451 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size_byte
- i
, len
);
459 /* Print the contents of a string STRING using PRINTCHARFUN.
460 It isn't safe to use strout in many cases,
461 because printing one char can relocate. */
464 print_string (string
, printcharfun
)
466 Lisp_Object printcharfun
;
468 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
472 if (STRING_MULTIBYTE (string
))
473 chars
= XSTRING (string
)->size
;
474 else if (EQ (printcharfun
, Qt
)
475 ? ! NILP (buffer_defaults
.enable_multibyte_characters
)
476 : ! NILP (current_buffer
->enable_multibyte_characters
))
477 chars
= multibyte_chars_in_text (XSTRING (string
)->data
,
478 STRING_BYTES (XSTRING (string
)));
480 chars
= STRING_BYTES (XSTRING (string
));
482 /* strout is safe for output to a frame (echo area) or to print_buffer. */
483 strout (XSTRING (string
)->data
,
484 chars
, STRING_BYTES (XSTRING (string
)),
485 printcharfun
, STRING_MULTIBYTE (string
));
489 /* Otherwise, string may be relocated by printing one char.
490 So re-fetch the string address for each character. */
492 int size
= XSTRING (string
)->size
;
493 int size_byte
= STRING_BYTES (XSTRING (string
));
496 if (size
== size_byte
)
497 for (i
= 0; i
< size
; i
++)
498 PRINTCHAR (XSTRING (string
)->data
[i
]);
500 for (i
= 0; i
< size_byte
; i
++)
502 /* Here, we must convert each multi-byte form to the
503 corresponding character code before handing it to PRINTCHAR. */
505 int ch
= STRING_CHAR_AND_LENGTH (XSTRING (string
)->data
+ i
,
507 if (!CHAR_VALID_P (ch
, 0))
509 ch
= XSTRING (string
)->data
[i
];
519 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
520 "Output character CHARACTER to stream PRINTCHARFUN.\n\
521 PRINTCHARFUN defaults to the value of `standard-output' (which see).")
522 (character
, printcharfun
)
523 Lisp_Object character
, printcharfun
;
527 if (NILP (printcharfun
))
528 printcharfun
= Vstandard_output
;
529 CHECK_NUMBER (character
, 0);
531 PRINTCHAR (XINT (character
));
536 /* Used from outside of print.c to print a block of SIZE
537 single-byte chars at DATA on the default output stream.
538 Do not use this on the contents of a Lisp string. */
541 write_string (data
, size
)
546 Lisp_Object printcharfun
;
548 printcharfun
= Vstandard_output
;
551 strout (data
, size
, size
, printcharfun
, 0);
555 /* Used from outside of print.c to print a block of SIZE
556 single-byte chars at DATA on a specified stream PRINTCHARFUN.
557 Do not use this on the contents of a Lisp string. */
560 write_string_1 (data
, size
, printcharfun
)
563 Lisp_Object printcharfun
;
568 strout (data
, size
, size
, printcharfun
, 0);
574 temp_output_buffer_setup (bufname
)
577 int count
= specpdl_ptr
- specpdl
;
578 register struct buffer
*old
= current_buffer
;
579 register Lisp_Object buf
;
581 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
583 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
585 current_buffer
->directory
= old
->directory
;
586 current_buffer
->read_only
= Qnil
;
587 current_buffer
->filename
= Qnil
;
588 current_buffer
->undo_list
= Qt
;
589 current_buffer
->overlays_before
= Qnil
;
590 current_buffer
->overlays_after
= Qnil
;
591 current_buffer
->enable_multibyte_characters
592 = buffer_defaults
.enable_multibyte_characters
;
594 XSETBUFFER (buf
, current_buffer
);
596 call1 (Vrun_hooks
, Qtemp_buffer_setup_hook
);
598 unbind_to (count
, Qnil
);
600 specbind (Qstandard_output
, buf
);
604 internal_with_output_to_temp_buffer (bufname
, function
, args
)
606 Lisp_Object (*function
) P_ ((Lisp_Object
));
609 int count
= specpdl_ptr
- specpdl
;
610 Lisp_Object buf
, val
;
614 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
615 temp_output_buffer_setup (bufname
);
616 buf
= Vstandard_output
;
619 val
= (*function
) (args
);
622 temp_output_buffer_show (buf
);
625 return unbind_to (count
, val
);
628 DEFUN ("with-output-to-temp-buffer", Fwith_output_to_temp_buffer
, Swith_output_to_temp_buffer
,
630 "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.\n\
631 The buffer is cleared out initially, and marked as unmodified when done.\n\
632 All output done by BODY is inserted in that buffer by default.\n\
633 The buffer is displayed in another window, but not selected.\n\
634 The value of the last form in BODY is returned.\n\
635 If BODY does not finish normally, the buffer BUFNAME is not displayed.\n\
637 The hook `temp-buffer-setup-hook' is run before BODY,\n\
638 with the buffer BUFNAME temporarily current.\n\
639 The hook `temp-buffer-show-hook' is run after the buffer is displayed,\n\
640 with the buffer temporarily current, and the window that was used\n\
641 to display it temporarily selected.\n\
643 If variable `temp-buffer-show-function' is non-nil, call it at the end\n\
644 to get the buffer displayed instead of just displaying the non-selected\n\
645 buffer and calling the hook. It gets one argument, the buffer to display.")
651 int count
= specpdl_ptr
- specpdl
;
652 Lisp_Object buf
, val
;
655 name
= Feval (Fcar (args
));
658 CHECK_STRING (name
, 0);
659 temp_output_buffer_setup (XSTRING (name
)->data
);
660 buf
= Vstandard_output
;
662 val
= Fprogn (Fcdr (args
));
664 temp_output_buffer_show (buf
);
666 return unbind_to (count
, val
);
670 static void print ();
671 static void print_preprocess ();
672 #ifdef USE_TEXT_PROPERTIES
673 static void print_preprocess_string ();
674 #endif /* USE_TEXT_PROPERTIES */
675 static void print_object ();
677 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
678 "Output a newline to stream PRINTCHARFUN.\n\
679 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used.")
681 Lisp_Object printcharfun
;
685 if (NILP (printcharfun
))
686 printcharfun
= Vstandard_output
;
693 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
694 "Output the printed representation of OBJECT, any Lisp object.\n\
695 Quoting characters are printed when needed to make output that `read'\n\
696 can handle, whenever this is possible.\n\
697 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
698 (object
, printcharfun
)
699 Lisp_Object object
, printcharfun
;
703 #ifdef MAX_PRINT_CHARS
705 #endif /* MAX_PRINT_CHARS */
706 if (NILP (printcharfun
))
707 printcharfun
= Vstandard_output
;
709 print (object
, printcharfun
, 1);
714 /* a buffer which is used to hold output being built by prin1-to-string */
715 Lisp_Object Vprin1_to_string_buffer
;
717 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
718 "Return a string containing the printed representation of OBJECT,\n\
719 any Lisp object. Quoting characters are used when needed to make output\n\
720 that `read' can handle, whenever this is possible, unless the optional\n\
721 second argument NOESCAPE is non-nil.")
723 Lisp_Object object
, noescape
;
726 Lisp_Object printcharfun
;
727 struct gcpro gcpro1
, gcpro2
;
730 /* Save and restore this--we are altering a buffer
731 but we don't want to deactivate the mark just for that.
732 No need for specbind, since errors deactivate the mark. */
733 tem
= Vdeactivate_mark
;
734 GCPRO2 (object
, tem
);
736 printcharfun
= Vprin1_to_string_buffer
;
738 print (object
, printcharfun
, NILP (noescape
));
739 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
741 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
742 object
= Fbuffer_string ();
745 set_buffer_internal (old
);
747 Vdeactivate_mark
= tem
;
753 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
754 "Output the printed representation of OBJECT, any Lisp object.\n\
755 No quoting characters are used; no delimiters are printed around\n\
756 the contents of strings.\n\
757 Output stream is PRINTCHARFUN, or value of standard-output (which see).")
758 (object
, printcharfun
)
759 Lisp_Object object
, printcharfun
;
763 if (NILP (printcharfun
))
764 printcharfun
= Vstandard_output
;
766 print (object
, printcharfun
, 0);
771 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
772 "Output the printed representation of OBJECT, with newlines around it.\n\
773 Quoting characters are printed when needed to make output that `read'\n\
774 can handle, whenever this is possible.\n\
775 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
776 (object
, printcharfun
)
777 Lisp_Object object
, printcharfun
;
782 #ifdef MAX_PRINT_CHARS
784 max_print
= MAX_PRINT_CHARS
;
785 #endif /* MAX_PRINT_CHARS */
786 if (NILP (printcharfun
))
787 printcharfun
= Vstandard_output
;
791 print (object
, printcharfun
, 1);
794 #ifdef MAX_PRINT_CHARS
797 #endif /* MAX_PRINT_CHARS */
802 /* The subroutine object for external-debugging-output is kept here
803 for the convenience of the debugger. */
804 Lisp_Object Qexternal_debugging_output
;
806 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
807 "Write CHARACTER to stderr.\n\
808 You can call print while debugging emacs, and pass it this function\n\
809 to make it write to the debugging output.\n")
811 Lisp_Object character
;
813 CHECK_NUMBER (character
, 0);
814 putc (XINT (character
), stderr
);
817 /* Send the output to a debugger (nothing happens if there isn't one). */
819 char buf
[2] = {(char) XINT (character
), '\0'};
820 OutputDebugString (buf
);
827 /* This is the interface for debugging printing. */
833 Fprin1 (arg
, Qexternal_debugging_output
);
834 fprintf (stderr
, "\r\n");
837 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
839 "Convert an error value (ERROR-SYMBOL . DATA) to an error message.")
843 struct buffer
*old
= current_buffer
;
847 /* If OBJ is (error STRING), just return STRING.
848 That is not only faster, it also avoids the need to allocate
849 space here when the error is due to memory full. */
850 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
851 && CONSP (XCDR (obj
))
852 && STRINGP (XCAR (XCDR (obj
)))
853 && NILP (XCDR (XCDR (obj
))))
854 return XCAR (XCDR (obj
));
856 print_error_message (obj
, Vprin1_to_string_buffer
);
858 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
859 value
= Fbuffer_string ();
863 set_buffer_internal (old
);
869 /* Print an error message for the error DATA
870 onto Lisp output stream STREAM (suitable for the print functions). */
873 print_error_message (data
, stream
)
874 Lisp_Object data
, stream
;
876 Lisp_Object errname
, errmsg
, file_error
, tail
;
880 errname
= Fcar (data
);
882 if (EQ (errname
, Qerror
))
885 if (!CONSP (data
)) data
= Qnil
;
886 errmsg
= Fcar (data
);
891 errmsg
= Fget (errname
, Qerror_message
);
892 file_error
= Fmemq (Qfile_error
,
893 Fget (errname
, Qerror_conditions
));
896 /* Print an error message including the data items. */
898 tail
= Fcdr_safe (data
);
901 /* For file-error, make error message by concatenating
902 all the data items. They are all strings. */
903 if (!NILP (file_error
) && CONSP (tail
))
904 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
906 if (STRINGP (errmsg
))
907 Fprinc (errmsg
, stream
);
909 write_string_1 ("peculiar error", -1, stream
);
911 for (i
= 0; CONSP (tail
); tail
= Fcdr (tail
), i
++)
913 write_string_1 (i
? ", " : ": ", 2, stream
);
914 if (!NILP (file_error
))
915 Fprinc (Fcar (tail
), stream
);
917 Fprin1 (Fcar (tail
), stream
);
922 #ifdef LISP_FLOAT_TYPE
925 * The buffer should be at least as large as the max string size of the
926 * largest float, printed in the biggest notation. This is undoubtedly
927 * 20d float_output_format, with the negative of the C-constant "HUGE"
930 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
932 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
933 * case of -1e307 in 20d float_output_format. What is one to do (short of
934 * re-writing _doprnt to be more sane)?
939 float_to_string (buf
, data
)
946 /* Check for plus infinity in a way that won't lose
947 if there is no plus infinity. */
948 if (data
== data
/ 2 && data
> 1.0)
950 strcpy (buf
, "1.0e+INF");
953 /* Likewise for minus infinity. */
954 if (data
== data
/ 2 && data
< -1.0)
956 strcpy (buf
, "-1.0e+INF");
959 /* Check for NaN in a way that won't fail if there are no NaNs. */
960 if (! (data
* 0.0 >= 0.0))
962 /* Prepend "-" if the NaN's sign bit is negative.
963 The sign bit of a double is the bit that is 1 in -0.0. */
965 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
967 u_minus_zero
.d
= - 0.0;
968 for (i
= 0; i
< sizeof (double); i
++)
969 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
975 strcpy (buf
, "0.0e+NaN");
979 if (NILP (Vfloat_output_format
)
980 || !STRINGP (Vfloat_output_format
))
983 /* Generate the fewest number of digits that represent the
984 floating point value without losing information.
985 The following method is simple but a bit slow.
986 For ideas about speeding things up, please see:
988 Guy L Steele Jr & Jon L White, How to print floating-point numbers
989 accurately. SIGPLAN notices 25, 6 (June 1990), 112-126.
991 Robert G Burger & R Kent Dybvig, Printing floating point numbers
992 quickly and accurately, SIGPLAN notices 31, 5 (May 1996), 108-116. */
994 width
= fabs (data
) < DBL_MIN
? 1 : DBL_DIG
;
996 sprintf (buf
, "%.*g", width
, data
);
997 while (width
++ < DOUBLE_DIGITS_BOUND
&& atof (buf
) != data
);
1001 /* Check that the spec we have is fully valid.
1002 This means not only valid for printf,
1003 but meant for floats, and reasonable. */
1004 cp
= XSTRING (Vfloat_output_format
)->data
;
1013 /* Check the width specification. */
1015 if ('0' <= *cp
&& *cp
<= '9')
1019 width
= (width
* 10) + (*cp
++ - '0');
1020 while (*cp
>= '0' && *cp
<= '9');
1022 /* A precision of zero is valid only for %f. */
1024 || (width
== 0 && *cp
!= 'f'))
1028 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1034 sprintf (buf
, XSTRING (Vfloat_output_format
)->data
, data
);
1037 /* Make sure there is a decimal point with digit after, or an
1038 exponent, so that the value is readable as a float. But don't do
1039 this with "%.0f"; it's valid for that not to produce a decimal
1040 point. Note that width can be 0 only for %.0f. */
1043 for (cp
= buf
; *cp
; cp
++)
1044 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1047 if (*cp
== '.' && cp
[1] == 0)
1061 #endif /* LISP_FLOAT_TYPE */
1064 print (obj
, printcharfun
, escapeflag
)
1066 register Lisp_Object printcharfun
;
1071 /* Reset print_number_index and Vprint_number_table only when
1072 the variable Vprint_continuous_numbering is nil. Otherwise,
1073 the values of these variables will be kept between several
1075 if (NILP (Vprint_continuous_numbering
))
1077 print_number_index
= 0;
1078 Vprint_number_table
= Qnil
;
1081 /* Construct Vprint_number_table for print-gensym and print-circle. */
1082 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1084 int i
, start
, index
;
1085 /* Construct Vprint_number_table. */
1086 start
= index
= print_number_index
;
1087 print_preprocess (obj
);
1088 /* Remove unnecessary objects, which appear only once in OBJ;
1089 that is, whose status is Qnil. */
1090 for (i
= start
; i
< print_number_index
; i
++)
1091 if (!NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1093 PRINT_NUMBER_OBJECT (Vprint_number_table
, index
)
1094 = PRINT_NUMBER_OBJECT (Vprint_number_table
, i
);
1095 /* Reset the status field for the next print step. Now this
1096 field means whether the object has already been printed. */
1097 PRINT_NUMBER_STATUS (Vprint_number_table
, index
) = Qnil
;
1100 print_number_index
= index
;
1103 print_object (obj
, printcharfun
, escapeflag
);
1106 /* Construct Vprint_number_table according to the structure of OBJ.
1107 OBJ itself and all its elements will be added to Vprint_number_table
1108 recursively if it is a list, vector, compiled function, char-table,
1109 string (its text properties will be traced), or a symbol that has
1110 no obarray (this is for the print-gensym feature).
1111 The status fields of Vprint_number_table mean whether each object appears
1112 more than once in OBJ: Qnil at the first time, and Qt after that . */
1114 print_preprocess (obj
)
1120 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1121 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
)
1122 || (! NILP (Vprint_gensym
)
1123 && SYMBOLP (obj
) && NILP (XSYMBOL (obj
)->obarray
)))
1125 /* In case print-circle is nil and print-gensym is t,
1126 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1127 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1129 for (i
= 0; i
< print_number_index
; i
++)
1130 if (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
) == obj
)
1132 /* OBJ appears more than once. Let's remember that. */
1133 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1137 /* OBJ is not yet recorded. Let's add to the table. */
1138 if (print_number_index
== 0)
1140 /* Initialize the table. */
1141 Vprint_number_table
= Fmake_vector (make_number (40), Qnil
);
1143 else if (XVECTOR (Vprint_number_table
)->size
== print_number_index
* 2)
1145 /* Reallocate the table. */
1146 int i
= print_number_index
* 4;
1147 Lisp_Object old_table
= Vprint_number_table
;
1148 Vprint_number_table
= Fmake_vector (make_number (i
), Qnil
);
1149 for (i
= 0; i
< print_number_index
; i
++)
1151 PRINT_NUMBER_OBJECT (Vprint_number_table
, i
)
1152 = PRINT_NUMBER_OBJECT (old_table
, i
);
1153 PRINT_NUMBER_STATUS (Vprint_number_table
, i
)
1154 = PRINT_NUMBER_STATUS (old_table
, i
);
1157 PRINT_NUMBER_OBJECT (Vprint_number_table
, print_number_index
) = obj
;
1158 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1159 always print the gensym with a number. This is a special for
1160 the lisp function byte-compile-output-docform. */
1161 if (! NILP (Vprint_continuous_numbering
) && SYMBOLP (obj
)
1162 && NILP (XSYMBOL (obj
)->obarray
))
1163 PRINT_NUMBER_STATUS (Vprint_number_table
, print_number_index
) = Qt
;
1164 print_number_index
++;
1167 switch (XGCTYPE (obj
))
1170 #ifdef USE_TEXT_PROPERTIES
1171 /* A string may have text properties, which can be circular. */
1172 traverse_intervals (XSTRING (obj
)->intervals
, 0, 0,
1173 print_preprocess_string
, Qnil
);
1174 #endif /* USE_TEXT_PROPERTIES */
1178 print_preprocess (XCAR (obj
));
1182 case Lisp_Vectorlike
:
1183 size
= XVECTOR (obj
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1184 for (i
= 0; i
< size
; i
++)
1185 print_preprocess (XVECTOR (obj
)->contents
[i
]);
1190 #ifdef USE_TEXT_PROPERTIES
1192 print_preprocess_string (interval
, arg
)
1196 print_preprocess (interval
->plist
);
1198 #endif /* USE_TEXT_PROPERTIES */
1201 print_object (obj
, printcharfun
, escapeflag
)
1203 register Lisp_Object printcharfun
;
1210 /* Detect circularities and truncate them. */
1211 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1212 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
)
1213 || (! NILP (Vprint_gensym
)
1214 && SYMBOLP (obj
) && NILP (XSYMBOL (obj
)->obarray
)))
1216 if (NILP (Vprint_circle
) && NILP (Vprint_gensym
))
1218 /* Simple but incomplete way. */
1220 for (i
= 0; i
< print_depth
; i
++)
1221 if (EQ (obj
, being_printed
[i
]))
1223 sprintf (buf
, "#%d", i
);
1224 strout (buf
, -1, -1, printcharfun
, 0);
1227 being_printed
[print_depth
] = obj
;
1231 /* With the print-circle feature. */
1233 for (i
= 0; i
< print_number_index
; i
++)
1234 if (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
) == obj
)
1236 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1238 /* Add a prefix #n= if OBJ has not yet been printed;
1239 that is, its status field is nil. */
1240 sprintf (buf
, "#%d=", i
+ 1);
1241 strout (buf
, -1, -1, printcharfun
, 0);
1242 /* OBJ is going to be printed. Set the status to t. */
1243 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1248 /* Just print #n# if OBJ has already been printed. */
1249 sprintf (buf
, "#%d#", i
+ 1);
1250 strout (buf
, -1, -1, printcharfun
, 0);
1259 if (print_depth
> PRINT_CIRCLE
)
1260 error ("Apparently circular structure being printed");
1261 #ifdef MAX_PRINT_CHARS
1262 if (max_print
&& print_chars
> max_print
)
1267 #endif /* MAX_PRINT_CHARS */
1269 switch (XGCTYPE (obj
))
1272 if (sizeof (int) == sizeof (EMACS_INT
))
1273 sprintf (buf
, "%d", XINT (obj
));
1274 else if (sizeof (long) == sizeof (EMACS_INT
))
1275 sprintf (buf
, "%ld", (long) XINT (obj
));
1278 strout (buf
, -1, -1, printcharfun
, 0);
1281 #ifdef LISP_FLOAT_TYPE
1284 char pigbuf
[350]; /* see comments in float_to_string */
1286 float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1287 strout (pigbuf
, -1, -1, printcharfun
, 0);
1294 print_string (obj
, printcharfun
);
1297 register int i
, i_byte
;
1298 struct gcpro gcpro1
;
1301 /* 1 means we must ensure that the next character we output
1302 cannot be taken as part of a hex character escape. */
1303 int need_nonhex
= 0;
1307 #ifdef USE_TEXT_PROPERTIES
1308 if (!NULL_INTERVAL_P (XSTRING (obj
)->intervals
))
1316 str
= XSTRING (obj
)->data
;
1317 size_byte
= STRING_BYTES (XSTRING (obj
));
1319 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1321 /* Here, we must convert each multi-byte form to the
1322 corresponding character code before handing it to PRINTCHAR. */
1326 if (STRING_MULTIBYTE (obj
))
1328 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
,
1329 size_byte
- i_byte
, len
);
1330 if (CHAR_VALID_P (c
, 0))
1340 if (c
== '\n' && print_escape_newlines
)
1345 else if (c
== '\f' && print_escape_newlines
)
1350 else if (! SINGLE_BYTE_CHAR_P (c
) && print_escape_multibyte
)
1352 /* When multibyte is disabled,
1353 print multibyte string chars using hex escapes. */
1354 unsigned char outbuf
[50];
1355 sprintf (outbuf
, "\\x%x", c
);
1356 strout (outbuf
, -1, -1, printcharfun
, 0);
1359 else if (SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1360 && print_escape_nonascii
)
1362 /* When printing in a multibyte buffer
1363 or when explicitly requested,
1364 print single-byte non-ASCII string chars
1365 using octal escapes. */
1366 unsigned char outbuf
[5];
1367 sprintf (outbuf
, "\\%03o", c
);
1368 strout (outbuf
, -1, -1, printcharfun
, 0);
1372 /* If we just had a hex escape, and this character
1373 could be taken as part of it,
1374 output `\ ' to prevent that. */
1378 if ((c
>= 'a' && c
<= 'f')
1379 || (c
>= 'A' && c
<= 'F')
1380 || (c
>= '0' && c
<= '9'))
1381 strout ("\\ ", -1, -1, printcharfun
, 0);
1384 if (c
== '\"' || c
== '\\')
1391 #ifdef USE_TEXT_PROPERTIES
1392 if (!NULL_INTERVAL_P (XSTRING (obj
)->intervals
))
1394 traverse_intervals (XSTRING (obj
)->intervals
,
1395 0, 0, print_interval
, printcharfun
);
1406 register int confusing
;
1407 register unsigned char *p
= XSYMBOL (obj
)->name
->data
;
1408 register unsigned char *end
= p
+ STRING_BYTES (XSYMBOL (obj
)->name
);
1410 int i
, i_byte
, size_byte
;
1413 XSETSTRING (name
, XSYMBOL (obj
)->name
);
1415 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1418 /* If symbol name begins with a digit, and ends with a digit,
1419 and contains nothing but digits and `e', it could be treated
1420 as a number. So set CONFUSING.
1422 Symbols that contain periods could also be taken as numbers,
1423 but periods are always escaped, so we don't have to worry
1425 else if (*p
>= '0' && *p
<= '9'
1426 && end
[-1] >= '0' && end
[-1] <= '9')
1428 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1429 /* Needed for \2e10. */
1432 confusing
= (end
== p
);
1437 if (! NILP (Vprint_gensym
) && NILP (XSYMBOL (obj
)->obarray
))
1443 size_byte
= STRING_BYTES (XSTRING (name
));
1445 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1447 /* Here, we must convert each multi-byte form to the
1448 corresponding character code before handing it to PRINTCHAR. */
1450 if (STRING_MULTIBYTE (name
))
1451 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1453 c
= XSTRING (name
)->data
[i_byte
++];
1459 if (c
== '\"' || c
== '\\' || c
== '\''
1460 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1461 || c
== ',' || c
=='.' || c
== '`'
1462 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1464 PRINTCHAR ('\\'), confusing
= 0;
1472 /* If deeper than spec'd depth, print placeholder. */
1473 if (INTEGERP (Vprint_level
)
1474 && print_depth
> XINT (Vprint_level
))
1475 strout ("...", -1, -1, printcharfun
, 0);
1476 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1477 && (EQ (XCAR (obj
), Qquote
)))
1480 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1482 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1483 && (EQ (XCAR (obj
), Qfunction
)))
1487 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1489 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1490 && ((EQ (XCAR (obj
), Qbackquote
)
1491 || EQ (XCAR (obj
), Qcomma
)
1492 || EQ (XCAR (obj
), Qcomma_at
)
1493 || EQ (XCAR (obj
), Qcomma_dot
))))
1495 print_object (XCAR (obj
), printcharfun
, 0);
1496 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1503 register int print_length
= 0;
1504 Lisp_Object halftail
= obj
;
1506 if (INTEGERP (Vprint_length
))
1507 print_length
= XINT (Vprint_length
);
1510 /* Detect circular list. */
1511 if (NILP (Vprint_circle
))
1513 /* Simple but imcomplete way. */
1514 if (i
!= 0 && EQ (obj
, halftail
))
1516 sprintf (buf
, " . #%d", i
/ 2);
1517 strout (buf
, -1, -1, printcharfun
, 0);
1523 /* With the print-circle feature. */
1527 for (i
= 0; i
< print_number_index
; i
++)
1528 if (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
) == obj
)
1530 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1532 strout (" . ", 3, 3, printcharfun
, 0);
1533 print_object (obj
, printcharfun
, escapeflag
);
1537 sprintf (buf
, " . #%d#", i
+ 1);
1538 strout (buf
, -1, -1, printcharfun
, 0);
1546 if (print_length
&& i
> print_length
)
1548 strout ("...", 3, 3, printcharfun
, 0);
1551 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1554 halftail
= XCDR (halftail
);
1559 strout (" . ", 3, 3, printcharfun
, 0);
1560 print_object (obj
, printcharfun
, escapeflag
);
1567 case Lisp_Vectorlike
:
1572 strout ("#<process ", -1, -1, printcharfun
, 0);
1573 print_string (XPROCESS (obj
)->name
, printcharfun
);
1577 print_string (XPROCESS (obj
)->name
, printcharfun
);
1579 else if (BOOL_VECTOR_P (obj
))
1582 register unsigned char c
;
1583 struct gcpro gcpro1
;
1585 = (XBOOL_VECTOR (obj
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1591 sprintf (buf
, "%d", XBOOL_VECTOR (obj
)->size
);
1592 strout (buf
, -1, -1, printcharfun
, 0);
1595 /* Don't print more characters than the specified maximum. */
1596 if (INTEGERP (Vprint_length
)
1597 && XINT (Vprint_length
) < size_in_chars
)
1598 size_in_chars
= XINT (Vprint_length
);
1600 for (i
= 0; i
< size_in_chars
; i
++)
1603 c
= XBOOL_VECTOR (obj
)->data
[i
];
1604 if (c
== '\n' && print_escape_newlines
)
1609 else if (c
== '\f' && print_escape_newlines
)
1616 if (c
== '\"' || c
== '\\')
1625 else if (SUBRP (obj
))
1627 strout ("#<subr ", -1, -1, printcharfun
, 0);
1628 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
, 0);
1631 else if (WINDOWP (obj
))
1633 strout ("#<window ", -1, -1, printcharfun
, 0);
1634 sprintf (buf
, "%d", XFASTINT (XWINDOW (obj
)->sequence_number
));
1635 strout (buf
, -1, -1, printcharfun
, 0);
1636 if (!NILP (XWINDOW (obj
)->buffer
))
1638 strout (" on ", -1, -1, printcharfun
, 0);
1639 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1643 else if (HASH_TABLE_P (obj
))
1645 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1646 strout ("#<hash-table", -1, -1, printcharfun
, 0);
1647 if (SYMBOLP (h
->test
))
1651 strout (XSYMBOL (h
->test
)->name
->data
, -1, -1, printcharfun
, 0);
1653 strout (XSYMBOL (h
->weak
)->name
->data
, -1, -1, printcharfun
, 0);
1655 sprintf (buf
, "%d/%d", XFASTINT (h
->count
),
1656 XVECTOR (h
->next
)->size
);
1657 strout (buf
, -1, -1, printcharfun
, 0);
1659 sprintf (buf
, " 0x%lx", (unsigned long) h
);
1660 strout (buf
, -1, -1, printcharfun
, 0);
1663 else if (BUFFERP (obj
))
1665 if (NILP (XBUFFER (obj
)->name
))
1666 strout ("#<killed buffer>", -1, -1, printcharfun
, 0);
1667 else if (escapeflag
)
1669 strout ("#<buffer ", -1, -1, printcharfun
, 0);
1670 print_string (XBUFFER (obj
)->name
, printcharfun
);
1674 print_string (XBUFFER (obj
)->name
, printcharfun
);
1676 else if (WINDOW_CONFIGURATIONP (obj
))
1678 strout ("#<window-configuration>", -1, -1, printcharfun
, 0);
1680 else if (FRAMEP (obj
))
1682 strout ((FRAME_LIVE_P (XFRAME (obj
))
1683 ? "#<frame " : "#<dead frame "),
1684 -1, -1, printcharfun
, 0);
1685 print_string (XFRAME (obj
)->name
, printcharfun
);
1686 sprintf (buf
, " 0x%lx\\ ", (unsigned long) (XFRAME (obj
)));
1687 strout (buf
, -1, -1, printcharfun
, 0);
1692 int size
= XVECTOR (obj
)->size
;
1693 if (COMPILEDP (obj
))
1696 size
&= PSEUDOVECTOR_SIZE_MASK
;
1698 if (CHAR_TABLE_P (obj
))
1700 /* We print a char-table as if it were a vector,
1701 lumping the parent and default slots in with the
1702 character slots. But we add #^ as a prefix. */
1705 if (SUB_CHAR_TABLE_P (obj
))
1707 size
&= PSEUDOVECTOR_SIZE_MASK
;
1709 if (size
& PSEUDOVECTOR_FLAG
)
1715 register Lisp_Object tem
;
1717 /* Don't print more elements than the specified maximum. */
1718 if (INTEGERP (Vprint_length
)
1719 && XINT (Vprint_length
) < size
)
1720 size
= XINT (Vprint_length
);
1722 for (i
= 0; i
< size
; i
++)
1724 if (i
) PRINTCHAR (' ');
1725 tem
= XVECTOR (obj
)->contents
[i
];
1726 print_object (tem
, printcharfun
, escapeflag
);
1734 switch (XMISCTYPE (obj
))
1736 case Lisp_Misc_Marker
:
1737 strout ("#<marker ", -1, -1, printcharfun
, 0);
1738 /* Do you think this is necessary? */
1739 if (XMARKER (obj
)->insertion_type
!= 0)
1740 strout ("(before-insertion) ", -1, -1, printcharfun
, 0);
1741 if (!(XMARKER (obj
)->buffer
))
1742 strout ("in no buffer", -1, -1, printcharfun
, 0);
1745 sprintf (buf
, "at %d", marker_position (obj
));
1746 strout (buf
, -1, -1, printcharfun
, 0);
1747 strout (" in ", -1, -1, printcharfun
, 0);
1748 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
1753 case Lisp_Misc_Overlay
:
1754 strout ("#<overlay ", -1, -1, printcharfun
, 0);
1755 if (!(XMARKER (OVERLAY_START (obj
))->buffer
))
1756 strout ("in no buffer", -1, -1, printcharfun
, 0);
1759 sprintf (buf
, "from %d to %d in ",
1760 marker_position (OVERLAY_START (obj
)),
1761 marker_position (OVERLAY_END (obj
)));
1762 strout (buf
, -1, -1, printcharfun
, 0);
1763 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
1769 /* Remaining cases shouldn't happen in normal usage, but let's print
1770 them anyway for the benefit of the debugger. */
1771 case Lisp_Misc_Free
:
1772 strout ("#<misc free cell>", -1, -1, printcharfun
, 0);
1775 case Lisp_Misc_Intfwd
:
1776 sprintf (buf
, "#<intfwd to %d>", *XINTFWD (obj
)->intvar
);
1777 strout (buf
, -1, -1, printcharfun
, 0);
1780 case Lisp_Misc_Boolfwd
:
1781 sprintf (buf
, "#<boolfwd to %s>",
1782 (*XBOOLFWD (obj
)->boolvar
? "t" : "nil"));
1783 strout (buf
, -1, -1, printcharfun
, 0);
1786 case Lisp_Misc_Objfwd
:
1787 strout ("#<objfwd to ", -1, -1, printcharfun
, 0);
1788 print_object (*XOBJFWD (obj
)->objvar
, printcharfun
, escapeflag
);
1792 case Lisp_Misc_Buffer_Objfwd
:
1793 strout ("#<buffer_objfwd to ", -1, -1, printcharfun
, 0);
1794 print_object (*(Lisp_Object
*)((char *)current_buffer
1795 + XBUFFER_OBJFWD (obj
)->offset
),
1796 printcharfun
, escapeflag
);
1800 case Lisp_Misc_Kboard_Objfwd
:
1801 strout ("#<kboard_objfwd to ", -1, -1, printcharfun
, 0);
1802 print_object (*(Lisp_Object
*)((char *) current_kboard
1803 + XKBOARD_OBJFWD (obj
)->offset
),
1804 printcharfun
, escapeflag
);
1808 case Lisp_Misc_Buffer_Local_Value
:
1809 strout ("#<buffer_local_value ", -1, -1, printcharfun
, 0);
1810 goto do_buffer_local
;
1811 case Lisp_Misc_Some_Buffer_Local_Value
:
1812 strout ("#<some_buffer_local_value ", -1, -1, printcharfun
, 0);
1814 strout ("[realvalue] ", -1, -1, printcharfun
, 0);
1815 print_object (XBUFFER_LOCAL_VALUE (obj
)->realvalue
,
1816 printcharfun
, escapeflag
);
1817 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_buffer
)
1818 strout ("[local in buffer] ", -1, -1, printcharfun
, 0);
1820 strout ("[buffer] ", -1, -1, printcharfun
, 0);
1821 print_object (XBUFFER_LOCAL_VALUE (obj
)->buffer
,
1822 printcharfun
, escapeflag
);
1823 if (XBUFFER_LOCAL_VALUE (obj
)->check_frame
)
1825 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_frame
)
1826 strout ("[local in frame] ", -1, -1, printcharfun
, 0);
1828 strout ("[frame] ", -1, -1, printcharfun
, 0);
1829 print_object (XBUFFER_LOCAL_VALUE (obj
)->frame
,
1830 printcharfun
, escapeflag
);
1832 strout ("[alist-elt] ", -1, -1, printcharfun
, 0);
1833 print_object (XCAR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
1834 printcharfun
, escapeflag
);
1835 strout ("[default-value] ", -1, -1, printcharfun
, 0);
1836 print_object (XCDR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
1837 printcharfun
, escapeflag
);
1849 /* We're in trouble if this happens!
1850 Probably should just abort () */
1851 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
, 0);
1853 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
1854 else if (VECTORLIKEP (obj
))
1855 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
1857 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
1858 strout (buf
, -1, -1, printcharfun
, 0);
1859 strout (" Save your buffers immediately and please report this bug>",
1860 -1, -1, printcharfun
, 0);
1867 #ifdef USE_TEXT_PROPERTIES
1869 /* Print a description of INTERVAL using PRINTCHARFUN.
1870 This is part of printing a string that has text properties. */
1873 print_interval (interval
, printcharfun
)
1875 Lisp_Object printcharfun
;
1878 print_object (make_number (interval
->position
), printcharfun
, 1);
1880 print_object (make_number (interval
->position
+ LENGTH (interval
)),
1883 print_object (interval
->plist
, printcharfun
, 1);
1886 #endif /* USE_TEXT_PROPERTIES */
1891 Qtemp_buffer_setup_hook
= intern ("temp-buffer-setup-hook");
1892 staticpro (&Qtemp_buffer_setup_hook
);
1894 DEFVAR_LISP ("standard-output", &Vstandard_output
,
1895 "Output stream `print' uses by default for outputting a character.\n\
1896 This may be any function of one argument.\n\
1897 It may also be a buffer (output is inserted before point)\n\
1898 or a marker (output is inserted and the marker is advanced)\n\
1899 or the symbol t (output appears in the echo area).");
1900 Vstandard_output
= Qt
;
1901 Qstandard_output
= intern ("standard-output");
1902 staticpro (&Qstandard_output
);
1904 #ifdef LISP_FLOAT_TYPE
1905 DEFVAR_LISP ("float-output-format", &Vfloat_output_format
,
1906 "The format descriptor string used to print floats.\n\
1907 This is a %-spec like those accepted by `printf' in C,\n\
1908 but with some restrictions. It must start with the two characters `%.'.\n\
1909 After that comes an integer precision specification,\n\
1910 and then a letter which controls the format.\n\
1911 The letters allowed are `e', `f' and `g'.\n\
1912 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"\n\
1913 Use `f' for decimal point notation \"DIGITS.DIGITS\".\n\
1914 Use `g' to choose the shorter of those two formats for the number at hand.\n\
1915 The precision in any of these cases is the number of digits following\n\
1916 the decimal point. With `f', a precision of 0 means to omit the\n\
1917 decimal point. 0 is not allowed with `e' or `g'.\n\n\
1918 A value of nil means to use the shortest notation\n\
1919 that represents the number without losing information.");
1920 Vfloat_output_format
= Qnil
;
1921 Qfloat_output_format
= intern ("float-output-format");
1922 staticpro (&Qfloat_output_format
);
1923 #endif /* LISP_FLOAT_TYPE */
1925 DEFVAR_LISP ("print-length", &Vprint_length
,
1926 "Maximum length of list to print before abbreviating.\n\
1927 A value of nil means no limit.");
1928 Vprint_length
= Qnil
;
1930 DEFVAR_LISP ("print-level", &Vprint_level
,
1931 "Maximum depth of list nesting to print before abbreviating.\n\
1932 A value of nil means no limit.");
1933 Vprint_level
= Qnil
;
1935 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines
,
1936 "Non-nil means print newlines in strings as backslash-n.\n\
1937 Also print formfeeds as backslash-f.");
1938 print_escape_newlines
= 0;
1940 DEFVAR_BOOL ("print-escape-nonascii", &print_escape_nonascii
,
1941 "Non-nil means print unibyte non-ASCII chars in strings as \\OOO.\n\
1942 \(OOO is the octal representation of the character code.)\n\
1943 Only single-byte characters are affected, and only in `prin1'.");
1944 print_escape_nonascii
= 0;
1946 DEFVAR_BOOL ("print-escape-multibyte", &print_escape_multibyte
,
1947 "Non-nil means print multibyte characters in strings as \\xXXXX.\n\
1948 \(XXX is the hex representation of the character code.)\n\
1949 This affects only `prin1'.");
1950 print_escape_multibyte
= 0;
1952 DEFVAR_BOOL ("print-quoted", &print_quoted
,
1953 "Non-nil means print quoted forms with reader syntax.\n\
1954 I.e., (quote foo) prints as 'foo, (function foo) as #'foo, and, backquoted\n\
1955 forms print in the new syntax.");
1958 DEFVAR_LISP ("print-gensym", &Vprint_gensym
,
1959 "Non-nil means print uninterned symbols so they will read as uninterned.\n\
1960 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.\n\
1961 When the uninterned symbol appears within a recursive data structure\n\
1962 and the symbol appears more than once, in addition use the #N# and #N=\n\
1963 constructs as needed, so that multiple references to the same symbol are\n\
1964 shared once again when the text is read back.");
1965 Vprint_gensym
= Qnil
;
1967 DEFVAR_LISP ("print-circle", &Vprint_circle
,
1968 "*Non-nil means print recursive structures using #N= and #N# syntax.\n\
1969 If nil, printing proceeds recursively and may lead to\n\
1970 `max-lisp-eval-depth' being exceeded or an error may occur:\n\
1971 \"Apparently circular structure being printed.\" Also see\n\
1972 `print-length' and `print-level'.\n\
1973 If non-nil, shared substructures anywhere in the structure are printed\n\
1974 with `#N=' before the first occurrence (in the order of the print\n\
1975 representation) and `#N#' in place of each subsequent occurrence,\n\
1976 where N is a positive decimal integer.");
1977 Vprint_circle
= Qnil
;
1979 DEFVAR_LISP ("print-continuous-numbering", &Vprint_continuous_numbering
,
1980 "*Non-nil means keep numbering between several print functions.\n\
1981 See `print-gensym' nad `print-circle'. See also `print-number-table'.");
1982 Vprint_continuous_numbering
= Qnil
;
1984 DEFVAR_LISP ("print-number-table", &Vprint_number_table
,
1985 "A vector keeping the information of the current printed object.\n\
1986 This variable shouldn't be modified in Lisp level, but should be binded\n\
1987 with nil using let at the same position with `print-continuous-numbering',\n\
1988 so that the value of this variable can be freed after printing.");
1989 Vprint_number_table
= Qnil
;
1991 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
1992 staticpro (&Vprin1_to_string_buffer
);
1995 defsubr (&Sprin1_to_string
);
1996 defsubr (&Serror_message_string
);
2000 defsubr (&Swrite_char
);
2001 defsubr (&Sexternal_debugging_output
);
2003 Qexternal_debugging_output
= intern ("external-debugging-output");
2004 staticpro (&Qexternal_debugging_output
);
2006 Qprint_escape_newlines
= intern ("print-escape-newlines");
2007 staticpro (&Qprint_escape_newlines
);
2009 Qprint_escape_multibyte
= intern ("print-escape-multibyte");
2010 staticpro (&Qprint_escape_multibyte
);
2012 Qprint_escape_nonascii
= intern ("print-escape-nonascii");
2013 staticpro (&Qprint_escape_nonascii
);
2015 defsubr (&Swith_output_to_temp_buffer
);