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"
34 #include "intervals.h"
36 Lisp_Object Vstandard_output
, Qstandard_output
;
38 Lisp_Object Qtemp_buffer_setup_hook
;
40 /* These are used to print like we read. */
41 extern Lisp_Object Qbackquote
, Qcomma
, Qcomma_at
, Qcomma_dot
, Qfunction
;
43 #ifdef LISP_FLOAT_TYPE
44 Lisp_Object Vfloat_output_format
, Qfloat_output_format
;
46 /* Work around a problem that happens because math.h on hpux 7
47 defines two static variables--which, in Emacs, are not really static,
48 because `static' is defined as nothing. The problem is that they are
49 defined both here and in lread.c.
50 These macros prevent the name conflict. */
51 #if defined (HPUX) && !defined (HPUX8)
52 #define _MAXLDBL print_maxldbl
53 #define _NMAXLDBL print_nmaxldbl
62 /* Default to values appropriate for IEEE floating point. */
67 #define DBL_MANT_DIG 53
73 #define DBL_MIN 2.2250738585072014e-308
76 #ifdef DBL_MIN_REPLACEMENT
78 #define DBL_MIN DBL_MIN_REPLACEMENT
81 /* Define DOUBLE_DIGITS_BOUND, an upper bound on the number of decimal digits
82 needed to express a float without losing information.
83 The general-case formula is valid for the usual case, IEEE floating point,
84 but many compilers can't optimize the formula to an integer constant,
85 so make a special case for it. */
86 #if FLT_RADIX == 2 && DBL_MANT_DIG == 53
87 #define DOUBLE_DIGITS_BOUND 17 /* IEEE floating point */
89 #define DOUBLE_DIGITS_BOUND ((int) ceil (log10 (pow (FLT_RADIX, DBL_MANT_DIG))))
92 #endif /* LISP_FLOAT_TYPE */
94 /* Avoid actual stack overflow in print. */
97 /* Detect most circularities to print finite output. */
98 #define PRINT_CIRCLE 200
99 Lisp_Object being_printed
[PRINT_CIRCLE
];
101 /* When printing into a buffer, first we put the text in this
102 block, then insert it all at once. */
105 /* Size allocated in print_buffer. */
106 int print_buffer_size
;
107 /* Chars stored in print_buffer. */
108 int print_buffer_pos
;
109 /* Bytes stored in print_buffer. */
110 int print_buffer_pos_byte
;
112 /* Maximum length of list to print in full; noninteger means
113 effectively infinity */
115 Lisp_Object Vprint_length
;
117 /* Maximum depth of list to print in full; noninteger means
118 effectively infinity. */
120 Lisp_Object Vprint_level
;
122 /* Nonzero means print newlines in strings as \n. */
124 int print_escape_newlines
;
126 /* Nonzero means to print single-byte non-ascii characters in strings as
129 int print_escape_nonascii
;
131 /* Nonzero means to print multibyte characters in strings as hex escapes. */
133 int print_escape_multibyte
;
135 Lisp_Object Qprint_escape_newlines
;
136 Lisp_Object Qprint_escape_multibyte
, Qprint_escape_nonascii
;
138 /* Nonzero means print (quote foo) forms as 'foo, etc. */
142 /* Non-nil means print #: before uninterned symbols. */
144 Lisp_Object Vprint_gensym
;
146 /* Non-nil means print recursive structures using #n= and #n# syntax. */
148 Lisp_Object Vprint_circle
;
150 /* Non-nil means keep continuous number for #n= and #n# syntax
151 between several print functions. */
153 Lisp_Object Vprint_continuous_numbering
;
155 /* Vprint_number_table is a vector like [OBJ1 STAT1 OBJ2 STAT2 ...],
156 where OBJn are objects going to be printed, and STATn are their status,
157 which may be different meanings during process. See the comments of
158 the functions print and print_preprocess for details.
159 print_number_index keeps the last position the next object should be added,
160 twice of which is the actual vector position in Vprint_number_table. */
161 int print_number_index
;
162 Lisp_Object Vprint_number_table
;
164 /* PRINT_NUMBER_OBJECT returns the I'th object in Vprint_number_table TABLE.
165 PRINT_NUMBER_STATUS returns the status of the I'th object in TABLE.
166 See the comment of the variable Vprint_number_table. */
167 #define PRINT_NUMBER_OBJECT(table,i) XVECTOR ((table))->contents[(i) * 2]
168 #define PRINT_NUMBER_STATUS(table,i) XVECTOR ((table))->contents[(i) * 2 + 1]
170 /* Nonzero means print newline to stdout before next minibuffer message.
171 Defined in xdisp.c */
173 extern int noninteractive_need_newline
;
175 extern int minibuffer_auto_raise
;
177 #ifdef MAX_PRINT_CHARS
178 static int print_chars
;
179 static int max_print
;
180 #endif /* MAX_PRINT_CHARS */
182 void print_interval ();
185 /* Low level output routines for characters and strings */
187 /* Lisp functions to do output using a stream
188 must have the stream in a variable called printcharfun
189 and must start with PRINTPREPARE, end with PRINTFINISH,
190 and use PRINTDECLARE to declare common variables.
191 Use PRINTCHAR to output one character,
192 or call strout to output a block of characters. */
194 #define PRINTDECLARE \
195 struct buffer *old = current_buffer; \
196 int old_point = -1, start_point; \
197 int old_point_byte, start_point_byte; \
198 int specpdl_count = specpdl_ptr - specpdl; \
199 int free_print_buffer = 0; \
200 int multibyte = !NILP (current_buffer->enable_multibyte_characters); \
203 #define PRINTPREPARE \
204 original = printcharfun; \
205 if (NILP (printcharfun)) printcharfun = Qt; \
206 if (BUFFERP (printcharfun)) \
208 if (XBUFFER (printcharfun) != current_buffer) \
209 Fset_buffer (printcharfun); \
210 printcharfun = Qnil; \
212 if (MARKERP (printcharfun)) \
214 if (!(XMARKER (original)->buffer)) \
215 error ("Marker does not point anywhere"); \
216 if (XMARKER (original)->buffer != current_buffer) \
217 set_buffer_internal (XMARKER (original)->buffer); \
219 old_point_byte = PT_BYTE; \
220 SET_PT_BOTH (marker_position (printcharfun), \
221 marker_byte_position (printcharfun)); \
223 start_point_byte = PT_BYTE; \
224 printcharfun = Qnil; \
226 if (NILP (printcharfun)) \
228 Lisp_Object string; \
229 if (NILP (current_buffer->enable_multibyte_characters) \
230 && ! print_escape_multibyte) \
231 specbind (Qprint_escape_multibyte, Qt); \
232 if (! NILP (current_buffer->enable_multibyte_characters) \
233 && ! print_escape_nonascii) \
234 specbind (Qprint_escape_nonascii, Qt); \
235 if (print_buffer != 0) \
237 string = make_string_from_bytes (print_buffer, \
239 print_buffer_pos_byte); \
240 record_unwind_protect (print_unwind, string); \
244 print_buffer_size = 1000; \
245 print_buffer = (char *) xmalloc (print_buffer_size); \
246 free_print_buffer = 1; \
248 print_buffer_pos = 0; \
249 print_buffer_pos_byte = 0; \
251 if (EQ (printcharfun, Qt) && ! noninteractive) \
252 setup_echo_area_for_printing (multibyte);
254 #define PRINTFINISH \
255 if (NILP (printcharfun)) \
257 if (print_buffer_pos != print_buffer_pos_byte \
258 && NILP (current_buffer->enable_multibyte_characters)) \
260 unsigned char *temp \
261 = (unsigned char *) alloca (print_buffer_pos + 1); \
262 copy_text (print_buffer, temp, print_buffer_pos_byte, \
264 insert_1_both (temp, print_buffer_pos, \
265 print_buffer_pos, 0, 1, 0); \
268 insert_1_both (print_buffer, print_buffer_pos, \
269 print_buffer_pos_byte, 0, 1, 0); \
271 if (free_print_buffer) \
273 xfree (print_buffer); \
276 unbind_to (specpdl_count, Qnil); \
277 if (MARKERP (original)) \
278 set_marker_both (original, Qnil, PT, PT_BYTE); \
279 if (old_point >= 0) \
280 SET_PT_BOTH (old_point + (old_point >= start_point \
281 ? PT - start_point : 0), \
282 old_point_byte + (old_point_byte >= start_point_byte \
283 ? PT_BYTE - start_point_byte : 0)); \
284 if (old != current_buffer) \
285 set_buffer_internal (old);
287 #define PRINTCHAR(ch) printchar (ch, printcharfun)
289 /* This is used to restore the saved contents of print_buffer
290 when there is a recursive call to print. */
293 print_unwind (saved_text
)
294 Lisp_Object saved_text
;
296 bcopy (XSTRING (saved_text
)->data
, print_buffer
, XSTRING (saved_text
)->size
);
300 /* Print character CH using method FUN. FUN nil means print to
301 print_buffer. FUN t means print to echo area or stdout if
302 non-interactive. If FUN is neither nil nor t, call FUN with CH as
310 #ifdef MAX_PRINT_CHARS
313 #endif /* MAX_PRINT_CHARS */
315 if (!NILP (fun
) && !EQ (fun
, Qt
))
316 call1 (fun
, make_number (ch
));
319 unsigned char work
[4], *str
;
320 int len
= CHAR_STRING (ch
, work
, str
);
326 if (print_buffer_pos_byte
+ len
>= print_buffer_size
)
327 print_buffer
= (char *) xrealloc (print_buffer
,
328 print_buffer_size
*= 2);
329 bcopy (str
, print_buffer
+ print_buffer_pos_byte
, len
);
330 print_buffer_pos
+= 1;
331 print_buffer_pos_byte
+= len
;
333 else if (noninteractive
)
335 fwrite (str
, 1, len
, stdout
);
336 noninteractive_need_newline
= 1;
341 = !NILP (current_buffer
->enable_multibyte_characters
);
343 if (!message_buf_print
)
344 setup_echo_area_for_printing (multibyte_p
);
347 message_dolog (str
, len
, 0, multibyte_p
);
353 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
354 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
355 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
356 print_buffer. PRINTCHARFUN t means output to the echo area or to
357 stdout if non-interactive. If neither nil nor t, call Lisp
358 function PRINTCHARFUN for each character printed. MULTIBYTE
359 non-zero means PTR contains multibyte characters. */
362 strout (ptr
, size
, size_byte
, printcharfun
, multibyte
)
365 Lisp_Object printcharfun
;
369 size_byte
= size
= strlen (ptr
);
371 if (NILP (printcharfun
))
373 if (print_buffer_pos_byte
+ size_byte
> print_buffer_size
)
375 print_buffer_size
= print_buffer_size
* 2 + size_byte
;
376 print_buffer
= (char *) xrealloc (print_buffer
,
379 bcopy (ptr
, print_buffer
+ print_buffer_pos_byte
, size_byte
);
380 print_buffer_pos
+= size
;
381 print_buffer_pos_byte
+= size_byte
;
383 #ifdef MAX_PRINT_CHARS
386 #endif /* MAX_PRINT_CHARS */
388 else if (noninteractive
&& EQ (printcharfun
, Qt
))
390 fwrite (ptr
, 1, size_byte
, stdout
);
391 noninteractive_need_newline
= 1;
393 else if (EQ (printcharfun
, Qt
))
395 /* Output to echo area. We're trying to avoid a little overhead
396 here, that's the reason we don't call printchar to do the
400 = !NILP (current_buffer
->enable_multibyte_characters
);
402 if (!message_buf_print
)
403 setup_echo_area_for_printing (multibyte_p
);
405 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
407 if (size
== size_byte
)
409 for (i
= 0; i
< size
; ++i
)
410 insert_char (*ptr
++);
415 for (i
= 0; i
< size_byte
; i
+= len
)
417 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size_byte
- i
, len
);
422 #ifdef MAX_PRINT_CHARS
425 #endif /* MAX_PRINT_CHARS */
429 /* PRINTCHARFUN is a Lisp function. */
432 if (size
== size_byte
)
434 while (i
< size_byte
)
442 while (i
< size_byte
)
444 /* Here, we must convert each multi-byte form to the
445 corresponding character code before handing it to
448 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size_byte
- i
, len
);
456 /* Print the contents of a string STRING using PRINTCHARFUN.
457 It isn't safe to use strout in many cases,
458 because printing one char can relocate. */
461 print_string (string
, printcharfun
)
463 Lisp_Object printcharfun
;
465 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
469 if (STRING_MULTIBYTE (string
))
470 chars
= XSTRING (string
)->size
;
471 else if (EQ (printcharfun
, Qt
)
472 ? ! NILP (buffer_defaults
.enable_multibyte_characters
)
473 : ! NILP (current_buffer
->enable_multibyte_characters
))
474 chars
= multibyte_chars_in_text (XSTRING (string
)->data
,
475 STRING_BYTES (XSTRING (string
)));
477 chars
= STRING_BYTES (XSTRING (string
));
479 /* strout is safe for output to a frame (echo area) or to print_buffer. */
480 strout (XSTRING (string
)->data
,
481 chars
, STRING_BYTES (XSTRING (string
)),
482 printcharfun
, STRING_MULTIBYTE (string
));
486 /* Otherwise, string may be relocated by printing one char.
487 So re-fetch the string address for each character. */
489 int size
= XSTRING (string
)->size
;
490 int size_byte
= STRING_BYTES (XSTRING (string
));
493 if (size
== size_byte
)
494 for (i
= 0; i
< size
; i
++)
495 PRINTCHAR (XSTRING (string
)->data
[i
]);
497 for (i
= 0; i
< size_byte
; i
++)
499 /* Here, we must convert each multi-byte form to the
500 corresponding character code before handing it to PRINTCHAR. */
502 int ch
= STRING_CHAR_AND_LENGTH (XSTRING (string
)->data
+ i
,
504 if (!CHAR_VALID_P (ch
, 0))
506 ch
= XSTRING (string
)->data
[i
];
516 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
517 "Output character CHARACTER to stream PRINTCHARFUN.\n\
518 PRINTCHARFUN defaults to the value of `standard-output' (which see).")
519 (character
, printcharfun
)
520 Lisp_Object character
, printcharfun
;
524 if (NILP (printcharfun
))
525 printcharfun
= Vstandard_output
;
526 CHECK_NUMBER (character
, 0);
528 PRINTCHAR (XINT (character
));
533 /* Used from outside of print.c to print a block of SIZE
534 single-byte chars at DATA on the default output stream.
535 Do not use this on the contents of a Lisp string. */
538 write_string (data
, size
)
543 Lisp_Object printcharfun
;
545 printcharfun
= Vstandard_output
;
548 strout (data
, size
, size
, printcharfun
, 0);
552 /* Used from outside of print.c to print a block of SIZE
553 single-byte chars at DATA on a specified stream PRINTCHARFUN.
554 Do not use this on the contents of a Lisp string. */
557 write_string_1 (data
, size
, printcharfun
)
560 Lisp_Object printcharfun
;
565 strout (data
, size
, size
, printcharfun
, 0);
571 temp_output_buffer_setup (bufname
)
574 int count
= specpdl_ptr
- specpdl
;
575 register struct buffer
*old
= current_buffer
;
576 register Lisp_Object buf
;
578 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
580 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
582 current_buffer
->directory
= old
->directory
;
583 current_buffer
->read_only
= Qnil
;
584 current_buffer
->filename
= Qnil
;
585 current_buffer
->undo_list
= Qt
;
586 current_buffer
->overlays_before
= Qnil
;
587 current_buffer
->overlays_after
= Qnil
;
588 current_buffer
->enable_multibyte_characters
589 = buffer_defaults
.enable_multibyte_characters
;
591 XSETBUFFER (buf
, current_buffer
);
593 call1 (Vrun_hooks
, Qtemp_buffer_setup_hook
);
595 unbind_to (count
, Qnil
);
597 specbind (Qstandard_output
, buf
);
601 internal_with_output_to_temp_buffer (bufname
, function
, args
)
603 Lisp_Object (*function
) P_ ((Lisp_Object
));
606 int count
= specpdl_ptr
- specpdl
;
607 Lisp_Object buf
, val
;
611 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
612 temp_output_buffer_setup (bufname
);
613 buf
= Vstandard_output
;
616 val
= (*function
) (args
);
619 temp_output_buffer_show (buf
);
622 return unbind_to (count
, val
);
625 DEFUN ("with-output-to-temp-buffer", Fwith_output_to_temp_buffer
, Swith_output_to_temp_buffer
,
627 "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.\n\
628 The buffer is cleared out initially, and marked as unmodified when done.\n\
629 All output done by BODY is inserted in that buffer by default.\n\
630 The buffer is displayed in another window, but not selected.\n\
631 The value of the last form in BODY is returned.\n\
632 If BODY does not finish normally, the buffer BUFNAME is not displayed.\n\
634 The hook `temp-buffer-setup-hook' is run before BODY,\n\
635 with the buffer BUFNAME temporarily current.\n\
636 The hook `temp-buffer-show-hook' is run after the buffer is displayed,\n\
637 with the buffer temporarily current, and the window that was used\n\
638 to display it temporarily selected.\n\
640 If variable `temp-buffer-show-function' is non-nil, call it at the end\n\
641 to get the buffer displayed instead of just displaying the non-selected\n\
642 buffer and calling the hook. It gets one argument, the buffer to display.")
648 int count
= specpdl_ptr
- specpdl
;
649 Lisp_Object buf
, val
;
652 name
= Feval (Fcar (args
));
655 CHECK_STRING (name
, 0);
656 temp_output_buffer_setup (XSTRING (name
)->data
);
657 buf
= Vstandard_output
;
659 val
= Fprogn (Fcdr (args
));
661 temp_output_buffer_show (buf
);
663 return unbind_to (count
, val
);
667 static void print ();
668 static void print_preprocess ();
669 static void print_preprocess_string ();
670 static void print_object ();
672 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
673 "Output a newline to stream PRINTCHARFUN.\n\
674 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used.")
676 Lisp_Object printcharfun
;
680 if (NILP (printcharfun
))
681 printcharfun
= Vstandard_output
;
688 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
689 "Output the printed representation of OBJECT, any Lisp object.\n\
690 Quoting characters are printed when needed to make output that `read'\n\
691 can handle, whenever this is possible.\n\
692 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
693 (object
, printcharfun
)
694 Lisp_Object object
, printcharfun
;
698 #ifdef MAX_PRINT_CHARS
700 #endif /* MAX_PRINT_CHARS */
701 if (NILP (printcharfun
))
702 printcharfun
= Vstandard_output
;
704 print (object
, printcharfun
, 1);
709 /* a buffer which is used to hold output being built by prin1-to-string */
710 Lisp_Object Vprin1_to_string_buffer
;
712 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
713 "Return a string containing the printed representation of OBJECT,\n\
714 any Lisp object. Quoting characters are used when needed to make output\n\
715 that `read' can handle, whenever this is possible, unless the optional\n\
716 second argument NOESCAPE is non-nil.")
718 Lisp_Object object
, noescape
;
721 Lisp_Object printcharfun
;
722 struct gcpro gcpro1
, gcpro2
;
725 /* Save and restore this--we are altering a buffer
726 but we don't want to deactivate the mark just for that.
727 No need for specbind, since errors deactivate the mark. */
728 tem
= Vdeactivate_mark
;
729 GCPRO2 (object
, tem
);
731 printcharfun
= Vprin1_to_string_buffer
;
733 print (object
, printcharfun
, NILP (noescape
));
734 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
736 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
737 object
= Fbuffer_string ();
740 set_buffer_internal (old
);
742 Vdeactivate_mark
= tem
;
748 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
749 "Output the printed representation of OBJECT, any Lisp object.\n\
750 No quoting characters are used; no delimiters are printed around\n\
751 the contents of strings.\n\
752 Output stream is PRINTCHARFUN, or value of standard-output (which see).")
753 (object
, printcharfun
)
754 Lisp_Object object
, printcharfun
;
758 if (NILP (printcharfun
))
759 printcharfun
= Vstandard_output
;
761 print (object
, printcharfun
, 0);
766 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
767 "Output the printed representation of OBJECT, with newlines around it.\n\
768 Quoting characters are printed when needed to make output that `read'\n\
769 can handle, whenever this is possible.\n\
770 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
771 (object
, printcharfun
)
772 Lisp_Object object
, printcharfun
;
777 #ifdef MAX_PRINT_CHARS
779 max_print
= MAX_PRINT_CHARS
;
780 #endif /* MAX_PRINT_CHARS */
781 if (NILP (printcharfun
))
782 printcharfun
= Vstandard_output
;
786 print (object
, printcharfun
, 1);
789 #ifdef MAX_PRINT_CHARS
792 #endif /* MAX_PRINT_CHARS */
797 /* The subroutine object for external-debugging-output is kept here
798 for the convenience of the debugger. */
799 Lisp_Object Qexternal_debugging_output
;
801 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
802 "Write CHARACTER to stderr.\n\
803 You can call print while debugging emacs, and pass it this function\n\
804 to make it write to the debugging output.\n")
806 Lisp_Object character
;
808 CHECK_NUMBER (character
, 0);
809 putc (XINT (character
), stderr
);
812 /* Send the output to a debugger (nothing happens if there isn't one). */
814 char buf
[2] = {(char) XINT (character
), '\0'};
815 OutputDebugString (buf
);
822 /* This is the interface for debugging printing. */
828 Fprin1 (arg
, Qexternal_debugging_output
);
829 fprintf (stderr
, "\r\n");
832 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
834 "Convert an error value (ERROR-SYMBOL . DATA) to an error message.")
838 struct buffer
*old
= current_buffer
;
842 /* If OBJ is (error STRING), just return STRING.
843 That is not only faster, it also avoids the need to allocate
844 space here when the error is due to memory full. */
845 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
846 && CONSP (XCDR (obj
))
847 && STRINGP (XCAR (XCDR (obj
)))
848 && NILP (XCDR (XCDR (obj
))))
849 return XCAR (XCDR (obj
));
851 print_error_message (obj
, Vprin1_to_string_buffer
);
853 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
854 value
= Fbuffer_string ();
858 set_buffer_internal (old
);
864 /* Print an error message for the error DATA
865 onto Lisp output stream STREAM (suitable for the print functions). */
868 print_error_message (data
, stream
)
869 Lisp_Object data
, stream
;
871 Lisp_Object errname
, errmsg
, file_error
, tail
;
875 errname
= Fcar (data
);
877 if (EQ (errname
, Qerror
))
880 if (!CONSP (data
)) data
= Qnil
;
881 errmsg
= Fcar (data
);
886 errmsg
= Fget (errname
, Qerror_message
);
887 file_error
= Fmemq (Qfile_error
,
888 Fget (errname
, Qerror_conditions
));
891 /* Print an error message including the data items. */
893 tail
= Fcdr_safe (data
);
896 /* For file-error, make error message by concatenating
897 all the data items. They are all strings. */
898 if (!NILP (file_error
) && CONSP (tail
))
899 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
901 if (STRINGP (errmsg
))
902 Fprinc (errmsg
, stream
);
904 write_string_1 ("peculiar error", -1, stream
);
906 for (i
= 0; CONSP (tail
); tail
= Fcdr (tail
), i
++)
908 write_string_1 (i
? ", " : ": ", 2, stream
);
909 if (!NILP (file_error
))
910 Fprinc (Fcar (tail
), stream
);
912 Fprin1 (Fcar (tail
), stream
);
917 #ifdef LISP_FLOAT_TYPE
920 * The buffer should be at least as large as the max string size of the
921 * largest float, printed in the biggest notation. This is undoubtedly
922 * 20d float_output_format, with the negative of the C-constant "HUGE"
925 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
927 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
928 * case of -1e307 in 20d float_output_format. What is one to do (short of
929 * re-writing _doprnt to be more sane)?
934 float_to_string (buf
, data
)
941 /* Check for plus infinity in a way that won't lose
942 if there is no plus infinity. */
943 if (data
== data
/ 2 && data
> 1.0)
945 strcpy (buf
, "1.0e+INF");
948 /* Likewise for minus infinity. */
949 if (data
== data
/ 2 && data
< -1.0)
951 strcpy (buf
, "-1.0e+INF");
954 /* Check for NaN in a way that won't fail if there are no NaNs. */
955 if (! (data
* 0.0 >= 0.0))
957 /* Prepend "-" if the NaN's sign bit is negative.
958 The sign bit of a double is the bit that is 1 in -0.0. */
960 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
962 u_minus_zero
.d
= - 0.0;
963 for (i
= 0; i
< sizeof (double); i
++)
964 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
970 strcpy (buf
, "0.0e+NaN");
974 if (NILP (Vfloat_output_format
)
975 || !STRINGP (Vfloat_output_format
))
978 /* Generate the fewest number of digits that represent the
979 floating point value without losing information.
980 The following method is simple but a bit slow.
981 For ideas about speeding things up, please see:
983 Guy L Steele Jr & Jon L White, How to print floating-point numbers
984 accurately. SIGPLAN notices 25, 6 (June 1990), 112-126.
986 Robert G Burger & R Kent Dybvig, Printing floating point numbers
987 quickly and accurately, SIGPLAN notices 31, 5 (May 1996), 108-116. */
989 width
= fabs (data
) < DBL_MIN
? 1 : DBL_DIG
;
991 sprintf (buf
, "%.*g", width
, data
);
992 while (width
++ < DOUBLE_DIGITS_BOUND
&& atof (buf
) != data
);
996 /* Check that the spec we have is fully valid.
997 This means not only valid for printf,
998 but meant for floats, and reasonable. */
999 cp
= XSTRING (Vfloat_output_format
)->data
;
1008 /* Check the width specification. */
1010 if ('0' <= *cp
&& *cp
<= '9')
1014 width
= (width
* 10) + (*cp
++ - '0');
1015 while (*cp
>= '0' && *cp
<= '9');
1017 /* A precision of zero is valid only for %f. */
1019 || (width
== 0 && *cp
!= 'f'))
1023 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1029 sprintf (buf
, XSTRING (Vfloat_output_format
)->data
, data
);
1032 /* Make sure there is a decimal point with digit after, or an
1033 exponent, so that the value is readable as a float. But don't do
1034 this with "%.0f"; it's valid for that not to produce a decimal
1035 point. Note that width can be 0 only for %.0f. */
1038 for (cp
= buf
; *cp
; cp
++)
1039 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1042 if (*cp
== '.' && cp
[1] == 0)
1056 #endif /* LISP_FLOAT_TYPE */
1059 print (obj
, printcharfun
, escapeflag
)
1061 register Lisp_Object printcharfun
;
1066 /* Reset print_number_index and Vprint_number_table only when
1067 the variable Vprint_continuous_numbering is nil. Otherwise,
1068 the values of these variables will be kept between several
1070 if (NILP (Vprint_continuous_numbering
))
1072 print_number_index
= 0;
1073 Vprint_number_table
= Qnil
;
1076 /* Construct Vprint_number_table for print-gensym and print-circle. */
1077 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1079 int i
, start
, index
;
1080 /* Construct Vprint_number_table. */
1081 start
= index
= print_number_index
;
1082 print_preprocess (obj
);
1083 /* Remove unnecessary objects, which appear only once in OBJ;
1084 that is, whose status is Qnil. */
1085 for (i
= start
; i
< print_number_index
; i
++)
1086 if (!NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1088 PRINT_NUMBER_OBJECT (Vprint_number_table
, index
)
1089 = PRINT_NUMBER_OBJECT (Vprint_number_table
, i
);
1090 /* Reset the status field for the next print step. Now this
1091 field means whether the object has already been printed. */
1092 PRINT_NUMBER_STATUS (Vprint_number_table
, index
) = Qnil
;
1095 print_number_index
= index
;
1098 print_object (obj
, printcharfun
, escapeflag
);
1101 /* Construct Vprint_number_table according to the structure of OBJ.
1102 OBJ itself and all its elements will be added to Vprint_number_table
1103 recursively if it is a list, vector, compiled function, char-table,
1104 string (its text properties will be traced), or a symbol that has
1105 no obarray (this is for the print-gensym feature).
1106 The status fields of Vprint_number_table mean whether each object appears
1107 more than once in OBJ: Qnil at the first time, and Qt after that . */
1109 print_preprocess (obj
)
1115 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1116 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
)
1117 || (! NILP (Vprint_gensym
)
1118 && SYMBOLP (obj
) && NILP (XSYMBOL (obj
)->obarray
)))
1120 /* In case print-circle is nil and print-gensym is t,
1121 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1122 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1124 for (i
= 0; i
< print_number_index
; i
++)
1125 if (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
) == obj
)
1127 /* OBJ appears more than once. Let's remember that. */
1128 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1132 /* OBJ is not yet recorded. Let's add to the table. */
1133 if (print_number_index
== 0)
1135 /* Initialize the table. */
1136 Vprint_number_table
= Fmake_vector (make_number (40), Qnil
);
1138 else if (XVECTOR (Vprint_number_table
)->size
== print_number_index
* 2)
1140 /* Reallocate the table. */
1141 int i
= print_number_index
* 4;
1142 Lisp_Object old_table
= Vprint_number_table
;
1143 Vprint_number_table
= Fmake_vector (make_number (i
), Qnil
);
1144 for (i
= 0; i
< print_number_index
; i
++)
1146 PRINT_NUMBER_OBJECT (Vprint_number_table
, i
)
1147 = PRINT_NUMBER_OBJECT (old_table
, i
);
1148 PRINT_NUMBER_STATUS (Vprint_number_table
, i
)
1149 = PRINT_NUMBER_STATUS (old_table
, i
);
1152 PRINT_NUMBER_OBJECT (Vprint_number_table
, print_number_index
) = obj
;
1153 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1154 always print the gensym with a number. This is a special for
1155 the lisp function byte-compile-output-docform. */
1156 if (! NILP (Vprint_continuous_numbering
) && SYMBOLP (obj
)
1157 && NILP (XSYMBOL (obj
)->obarray
))
1158 PRINT_NUMBER_STATUS (Vprint_number_table
, print_number_index
) = Qt
;
1159 print_number_index
++;
1162 switch (XGCTYPE (obj
))
1165 /* A string may have text properties, which can be circular. */
1166 traverse_intervals (XSTRING (obj
)->intervals
, 0, 0,
1167 print_preprocess_string
, Qnil
);
1171 print_preprocess (XCAR (obj
));
1175 case Lisp_Vectorlike
:
1176 size
= XVECTOR (obj
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1177 for (i
= 0; i
< size
; i
++)
1178 print_preprocess (XVECTOR (obj
)->contents
[i
]);
1184 print_preprocess_string (interval
, arg
)
1188 print_preprocess (interval
->plist
);
1192 print_object (obj
, printcharfun
, escapeflag
)
1194 register Lisp_Object printcharfun
;
1201 /* Detect circularities and truncate them. */
1202 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1203 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
)
1204 || (! NILP (Vprint_gensym
)
1205 && SYMBOLP (obj
) && NILP (XSYMBOL (obj
)->obarray
)))
1207 if (NILP (Vprint_circle
) && NILP (Vprint_gensym
))
1209 /* Simple but incomplete way. */
1211 for (i
= 0; i
< print_depth
; i
++)
1212 if (EQ (obj
, being_printed
[i
]))
1214 sprintf (buf
, "#%d", i
);
1215 strout (buf
, -1, -1, printcharfun
, 0);
1218 being_printed
[print_depth
] = obj
;
1222 /* With the print-circle feature. */
1224 for (i
= 0; i
< print_number_index
; i
++)
1225 if (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
) == obj
)
1227 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1229 /* Add a prefix #n= if OBJ has not yet been printed;
1230 that is, its status field is nil. */
1231 sprintf (buf
, "#%d=", i
+ 1);
1232 strout (buf
, -1, -1, printcharfun
, 0);
1233 /* OBJ is going to be printed. Set the status to t. */
1234 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1239 /* Just print #n# if OBJ has already been printed. */
1240 sprintf (buf
, "#%d#", i
+ 1);
1241 strout (buf
, -1, -1, printcharfun
, 0);
1250 if (print_depth
> PRINT_CIRCLE
)
1251 error ("Apparently circular structure being printed");
1252 #ifdef MAX_PRINT_CHARS
1253 if (max_print
&& print_chars
> max_print
)
1258 #endif /* MAX_PRINT_CHARS */
1260 switch (XGCTYPE (obj
))
1263 if (sizeof (int) == sizeof (EMACS_INT
))
1264 sprintf (buf
, "%d", XINT (obj
));
1265 else if (sizeof (long) == sizeof (EMACS_INT
))
1266 sprintf (buf
, "%ld", (long) XINT (obj
));
1269 strout (buf
, -1, -1, printcharfun
, 0);
1272 #ifdef LISP_FLOAT_TYPE
1275 char pigbuf
[350]; /* see comments in float_to_string */
1277 float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1278 strout (pigbuf
, -1, -1, printcharfun
, 0);
1285 print_string (obj
, printcharfun
);
1288 register int i
, i_byte
;
1289 struct gcpro gcpro1
;
1292 /* 1 means we must ensure that the next character we output
1293 cannot be taken as part of a hex character escape. */
1294 int need_nonhex
= 0;
1298 if (!NULL_INTERVAL_P (XSTRING (obj
)->intervals
))
1305 str
= XSTRING (obj
)->data
;
1306 size_byte
= STRING_BYTES (XSTRING (obj
));
1308 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1310 /* Here, we must convert each multi-byte form to the
1311 corresponding character code before handing it to PRINTCHAR. */
1315 if (STRING_MULTIBYTE (obj
))
1317 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
,
1318 size_byte
- i_byte
, len
);
1319 if (CHAR_VALID_P (c
, 0))
1329 if (c
== '\n' && print_escape_newlines
)
1334 else if (c
== '\f' && print_escape_newlines
)
1339 else if (! SINGLE_BYTE_CHAR_P (c
) && print_escape_multibyte
)
1341 /* When multibyte is disabled,
1342 print multibyte string chars using hex escapes. */
1343 unsigned char outbuf
[50];
1344 sprintf (outbuf
, "\\x%x", c
);
1345 strout (outbuf
, -1, -1, printcharfun
, 0);
1348 else if (SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1349 && print_escape_nonascii
)
1351 /* When printing in a multibyte buffer
1352 or when explicitly requested,
1353 print single-byte non-ASCII string chars
1354 using octal escapes. */
1355 unsigned char outbuf
[5];
1356 sprintf (outbuf
, "\\%03o", c
);
1357 strout (outbuf
, -1, -1, printcharfun
, 0);
1361 /* If we just had a hex escape, and this character
1362 could be taken as part of it,
1363 output `\ ' to prevent that. */
1367 if ((c
>= 'a' && c
<= 'f')
1368 || (c
>= 'A' && c
<= 'F')
1369 || (c
>= '0' && c
<= '9'))
1370 strout ("\\ ", -1, -1, printcharfun
, 0);
1373 if (c
== '\"' || c
== '\\')
1380 if (!NULL_INTERVAL_P (XSTRING (obj
)->intervals
))
1382 traverse_intervals (XSTRING (obj
)->intervals
,
1383 0, 0, print_interval
, printcharfun
);
1393 register int confusing
;
1394 register unsigned char *p
= XSYMBOL (obj
)->name
->data
;
1395 register unsigned char *end
= p
+ STRING_BYTES (XSYMBOL (obj
)->name
);
1397 int i
, i_byte
, size_byte
;
1400 XSETSTRING (name
, XSYMBOL (obj
)->name
);
1402 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1405 /* If symbol name begins with a digit, and ends with a digit,
1406 and contains nothing but digits and `e', it could be treated
1407 as a number. So set CONFUSING.
1409 Symbols that contain periods could also be taken as numbers,
1410 but periods are always escaped, so we don't have to worry
1412 else if (*p
>= '0' && *p
<= '9'
1413 && end
[-1] >= '0' && end
[-1] <= '9')
1415 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1416 /* Needed for \2e10. */
1419 confusing
= (end
== p
);
1424 if (! NILP (Vprint_gensym
) && NILP (XSYMBOL (obj
)->obarray
))
1430 size_byte
= STRING_BYTES (XSTRING (name
));
1432 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1434 /* Here, we must convert each multi-byte form to the
1435 corresponding character code before handing it to PRINTCHAR. */
1437 if (STRING_MULTIBYTE (name
))
1438 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1440 c
= XSTRING (name
)->data
[i_byte
++];
1446 if (c
== '\"' || c
== '\\' || c
== '\''
1447 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1448 || c
== ',' || c
=='.' || c
== '`'
1449 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1451 PRINTCHAR ('\\'), confusing
= 0;
1459 /* If deeper than spec'd depth, print placeholder. */
1460 if (INTEGERP (Vprint_level
)
1461 && print_depth
> XINT (Vprint_level
))
1462 strout ("...", -1, -1, printcharfun
, 0);
1463 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1464 && (EQ (XCAR (obj
), Qquote
)))
1467 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1469 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1470 && (EQ (XCAR (obj
), Qfunction
)))
1474 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1476 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1477 && ((EQ (XCAR (obj
), Qbackquote
)
1478 || EQ (XCAR (obj
), Qcomma
)
1479 || EQ (XCAR (obj
), Qcomma_at
)
1480 || EQ (XCAR (obj
), Qcomma_dot
))))
1482 print_object (XCAR (obj
), printcharfun
, 0);
1483 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1490 register int print_length
= 0;
1491 Lisp_Object halftail
= obj
;
1493 if (INTEGERP (Vprint_length
))
1494 print_length
= XINT (Vprint_length
);
1497 /* Detect circular list. */
1498 if (NILP (Vprint_circle
))
1500 /* Simple but imcomplete way. */
1501 if (i
!= 0 && EQ (obj
, halftail
))
1503 sprintf (buf
, " . #%d", i
/ 2);
1504 strout (buf
, -1, -1, printcharfun
, 0);
1510 /* With the print-circle feature. */
1514 for (i
= 0; i
< print_number_index
; i
++)
1515 if (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
) == obj
)
1517 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1519 strout (" . ", 3, 3, printcharfun
, 0);
1520 print_object (obj
, printcharfun
, escapeflag
);
1524 sprintf (buf
, " . #%d#", i
+ 1);
1525 strout (buf
, -1, -1, printcharfun
, 0);
1533 if (print_length
&& i
> print_length
)
1535 strout ("...", 3, 3, printcharfun
, 0);
1538 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1541 halftail
= XCDR (halftail
);
1546 strout (" . ", 3, 3, printcharfun
, 0);
1547 print_object (obj
, printcharfun
, escapeflag
);
1554 case Lisp_Vectorlike
:
1559 strout ("#<process ", -1, -1, printcharfun
, 0);
1560 print_string (XPROCESS (obj
)->name
, printcharfun
);
1564 print_string (XPROCESS (obj
)->name
, printcharfun
);
1566 else if (BOOL_VECTOR_P (obj
))
1569 register unsigned char c
;
1570 struct gcpro gcpro1
;
1572 = (XBOOL_VECTOR (obj
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1578 sprintf (buf
, "%d", XBOOL_VECTOR (obj
)->size
);
1579 strout (buf
, -1, -1, printcharfun
, 0);
1582 /* Don't print more characters than the specified maximum. */
1583 if (INTEGERP (Vprint_length
)
1584 && XINT (Vprint_length
) < size_in_chars
)
1585 size_in_chars
= XINT (Vprint_length
);
1587 for (i
= 0; i
< size_in_chars
; i
++)
1590 c
= XBOOL_VECTOR (obj
)->data
[i
];
1591 if (c
== '\n' && print_escape_newlines
)
1596 else if (c
== '\f' && print_escape_newlines
)
1603 if (c
== '\"' || c
== '\\')
1612 else if (SUBRP (obj
))
1614 strout ("#<subr ", -1, -1, printcharfun
, 0);
1615 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
, 0);
1618 else if (WINDOWP (obj
))
1620 strout ("#<window ", -1, -1, printcharfun
, 0);
1621 sprintf (buf
, "%d", XFASTINT (XWINDOW (obj
)->sequence_number
));
1622 strout (buf
, -1, -1, printcharfun
, 0);
1623 if (!NILP (XWINDOW (obj
)->buffer
))
1625 strout (" on ", -1, -1, printcharfun
, 0);
1626 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1630 else if (HASH_TABLE_P (obj
))
1632 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1633 strout ("#<hash-table", -1, -1, printcharfun
, 0);
1634 if (SYMBOLP (h
->test
))
1638 strout (XSYMBOL (h
->test
)->name
->data
, -1, -1, printcharfun
, 0);
1640 strout (XSYMBOL (h
->weak
)->name
->data
, -1, -1, printcharfun
, 0);
1642 sprintf (buf
, "%d/%d", XFASTINT (h
->count
),
1643 XVECTOR (h
->next
)->size
);
1644 strout (buf
, -1, -1, printcharfun
, 0);
1646 sprintf (buf
, " 0x%lx", (unsigned long) h
);
1647 strout (buf
, -1, -1, printcharfun
, 0);
1650 else if (BUFFERP (obj
))
1652 if (NILP (XBUFFER (obj
)->name
))
1653 strout ("#<killed buffer>", -1, -1, printcharfun
, 0);
1654 else if (escapeflag
)
1656 strout ("#<buffer ", -1, -1, printcharfun
, 0);
1657 print_string (XBUFFER (obj
)->name
, printcharfun
);
1661 print_string (XBUFFER (obj
)->name
, printcharfun
);
1663 else if (WINDOW_CONFIGURATIONP (obj
))
1665 strout ("#<window-configuration>", -1, -1, printcharfun
, 0);
1667 else if (FRAMEP (obj
))
1669 strout ((FRAME_LIVE_P (XFRAME (obj
))
1670 ? "#<frame " : "#<dead frame "),
1671 -1, -1, printcharfun
, 0);
1672 print_string (XFRAME (obj
)->name
, printcharfun
);
1673 sprintf (buf
, " 0x%lx\\ ", (unsigned long) (XFRAME (obj
)));
1674 strout (buf
, -1, -1, printcharfun
, 0);
1679 int size
= XVECTOR (obj
)->size
;
1680 if (COMPILEDP (obj
))
1683 size
&= PSEUDOVECTOR_SIZE_MASK
;
1685 if (CHAR_TABLE_P (obj
))
1687 /* We print a char-table as if it were a vector,
1688 lumping the parent and default slots in with the
1689 character slots. But we add #^ as a prefix. */
1692 if (SUB_CHAR_TABLE_P (obj
))
1694 size
&= PSEUDOVECTOR_SIZE_MASK
;
1696 if (size
& PSEUDOVECTOR_FLAG
)
1702 register Lisp_Object tem
;
1704 /* Don't print more elements than the specified maximum. */
1705 if (INTEGERP (Vprint_length
)
1706 && XINT (Vprint_length
) < size
)
1707 size
= XINT (Vprint_length
);
1709 for (i
= 0; i
< size
; i
++)
1711 if (i
) PRINTCHAR (' ');
1712 tem
= XVECTOR (obj
)->contents
[i
];
1713 print_object (tem
, printcharfun
, escapeflag
);
1721 switch (XMISCTYPE (obj
))
1723 case Lisp_Misc_Marker
:
1724 strout ("#<marker ", -1, -1, printcharfun
, 0);
1725 /* Do you think this is necessary? */
1726 if (XMARKER (obj
)->insertion_type
!= 0)
1727 strout ("(before-insertion) ", -1, -1, printcharfun
, 0);
1728 if (!(XMARKER (obj
)->buffer
))
1729 strout ("in no buffer", -1, -1, printcharfun
, 0);
1732 sprintf (buf
, "at %d", marker_position (obj
));
1733 strout (buf
, -1, -1, printcharfun
, 0);
1734 strout (" in ", -1, -1, printcharfun
, 0);
1735 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
1740 case Lisp_Misc_Overlay
:
1741 strout ("#<overlay ", -1, -1, printcharfun
, 0);
1742 if (!(XMARKER (OVERLAY_START (obj
))->buffer
))
1743 strout ("in no buffer", -1, -1, printcharfun
, 0);
1746 sprintf (buf
, "from %d to %d in ",
1747 marker_position (OVERLAY_START (obj
)),
1748 marker_position (OVERLAY_END (obj
)));
1749 strout (buf
, -1, -1, printcharfun
, 0);
1750 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
1756 /* Remaining cases shouldn't happen in normal usage, but let's print
1757 them anyway for the benefit of the debugger. */
1758 case Lisp_Misc_Free
:
1759 strout ("#<misc free cell>", -1, -1, printcharfun
, 0);
1762 case Lisp_Misc_Intfwd
:
1763 sprintf (buf
, "#<intfwd to %d>", *XINTFWD (obj
)->intvar
);
1764 strout (buf
, -1, -1, printcharfun
, 0);
1767 case Lisp_Misc_Boolfwd
:
1768 sprintf (buf
, "#<boolfwd to %s>",
1769 (*XBOOLFWD (obj
)->boolvar
? "t" : "nil"));
1770 strout (buf
, -1, -1, printcharfun
, 0);
1773 case Lisp_Misc_Objfwd
:
1774 strout ("#<objfwd to ", -1, -1, printcharfun
, 0);
1775 print_object (*XOBJFWD (obj
)->objvar
, printcharfun
, escapeflag
);
1779 case Lisp_Misc_Buffer_Objfwd
:
1780 strout ("#<buffer_objfwd to ", -1, -1, printcharfun
, 0);
1781 print_object (*(Lisp_Object
*)((char *)current_buffer
1782 + XBUFFER_OBJFWD (obj
)->offset
),
1783 printcharfun
, escapeflag
);
1787 case Lisp_Misc_Kboard_Objfwd
:
1788 strout ("#<kboard_objfwd to ", -1, -1, printcharfun
, 0);
1789 print_object (*(Lisp_Object
*)((char *) current_kboard
1790 + XKBOARD_OBJFWD (obj
)->offset
),
1791 printcharfun
, escapeflag
);
1795 case Lisp_Misc_Buffer_Local_Value
:
1796 strout ("#<buffer_local_value ", -1, -1, printcharfun
, 0);
1797 goto do_buffer_local
;
1798 case Lisp_Misc_Some_Buffer_Local_Value
:
1799 strout ("#<some_buffer_local_value ", -1, -1, printcharfun
, 0);
1801 strout ("[realvalue] ", -1, -1, printcharfun
, 0);
1802 print_object (XBUFFER_LOCAL_VALUE (obj
)->realvalue
,
1803 printcharfun
, escapeflag
);
1804 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_buffer
)
1805 strout ("[local in buffer] ", -1, -1, printcharfun
, 0);
1807 strout ("[buffer] ", -1, -1, printcharfun
, 0);
1808 print_object (XBUFFER_LOCAL_VALUE (obj
)->buffer
,
1809 printcharfun
, escapeflag
);
1810 if (XBUFFER_LOCAL_VALUE (obj
)->check_frame
)
1812 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_frame
)
1813 strout ("[local in frame] ", -1, -1, printcharfun
, 0);
1815 strout ("[frame] ", -1, -1, printcharfun
, 0);
1816 print_object (XBUFFER_LOCAL_VALUE (obj
)->frame
,
1817 printcharfun
, escapeflag
);
1819 strout ("[alist-elt] ", -1, -1, printcharfun
, 0);
1820 print_object (XCAR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
1821 printcharfun
, escapeflag
);
1822 strout ("[default-value] ", -1, -1, printcharfun
, 0);
1823 print_object (XCDR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
1824 printcharfun
, escapeflag
);
1836 /* We're in trouble if this happens!
1837 Probably should just abort () */
1838 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
, 0);
1840 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
1841 else if (VECTORLIKEP (obj
))
1842 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
1844 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
1845 strout (buf
, -1, -1, printcharfun
, 0);
1846 strout (" Save your buffers immediately and please report this bug>",
1847 -1, -1, printcharfun
, 0);
1855 /* Print a description of INTERVAL using PRINTCHARFUN.
1856 This is part of printing a string that has text properties. */
1859 print_interval (interval
, printcharfun
)
1861 Lisp_Object printcharfun
;
1864 print_object (make_number (interval
->position
), printcharfun
, 1);
1866 print_object (make_number (interval
->position
+ LENGTH (interval
)),
1869 print_object (interval
->plist
, printcharfun
, 1);
1876 Qtemp_buffer_setup_hook
= intern ("temp-buffer-setup-hook");
1877 staticpro (&Qtemp_buffer_setup_hook
);
1879 DEFVAR_LISP ("standard-output", &Vstandard_output
,
1880 "Output stream `print' uses by default for outputting a character.\n\
1881 This may be any function of one argument.\n\
1882 It may also be a buffer (output is inserted before point)\n\
1883 or a marker (output is inserted and the marker is advanced)\n\
1884 or the symbol t (output appears in the echo area).");
1885 Vstandard_output
= Qt
;
1886 Qstandard_output
= intern ("standard-output");
1887 staticpro (&Qstandard_output
);
1889 #ifdef LISP_FLOAT_TYPE
1890 DEFVAR_LISP ("float-output-format", &Vfloat_output_format
,
1891 "The format descriptor string used to print floats.\n\
1892 This is a %-spec like those accepted by `printf' in C,\n\
1893 but with some restrictions. It must start with the two characters `%.'.\n\
1894 After that comes an integer precision specification,\n\
1895 and then a letter which controls the format.\n\
1896 The letters allowed are `e', `f' and `g'.\n\
1897 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"\n\
1898 Use `f' for decimal point notation \"DIGITS.DIGITS\".\n\
1899 Use `g' to choose the shorter of those two formats for the number at hand.\n\
1900 The precision in any of these cases is the number of digits following\n\
1901 the decimal point. With `f', a precision of 0 means to omit the\n\
1902 decimal point. 0 is not allowed with `e' or `g'.\n\n\
1903 A value of nil means to use the shortest notation\n\
1904 that represents the number without losing information.");
1905 Vfloat_output_format
= Qnil
;
1906 Qfloat_output_format
= intern ("float-output-format");
1907 staticpro (&Qfloat_output_format
);
1908 #endif /* LISP_FLOAT_TYPE */
1910 DEFVAR_LISP ("print-length", &Vprint_length
,
1911 "Maximum length of list to print before abbreviating.\n\
1912 A value of nil means no limit.");
1913 Vprint_length
= Qnil
;
1915 DEFVAR_LISP ("print-level", &Vprint_level
,
1916 "Maximum depth of list nesting to print before abbreviating.\n\
1917 A value of nil means no limit.");
1918 Vprint_level
= Qnil
;
1920 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines
,
1921 "Non-nil means print newlines in strings as backslash-n.\n\
1922 Also print formfeeds as backslash-f.");
1923 print_escape_newlines
= 0;
1925 DEFVAR_BOOL ("print-escape-nonascii", &print_escape_nonascii
,
1926 "Non-nil means print unibyte non-ASCII chars in strings as \\OOO.\n\
1927 \(OOO is the octal representation of the character code.)\n\
1928 Only single-byte characters are affected, and only in `prin1'.");
1929 print_escape_nonascii
= 0;
1931 DEFVAR_BOOL ("print-escape-multibyte", &print_escape_multibyte
,
1932 "Non-nil means print multibyte characters in strings as \\xXXXX.\n\
1933 \(XXX is the hex representation of the character code.)\n\
1934 This affects only `prin1'.");
1935 print_escape_multibyte
= 0;
1937 DEFVAR_BOOL ("print-quoted", &print_quoted
,
1938 "Non-nil means print quoted forms with reader syntax.\n\
1939 I.e., (quote foo) prints as 'foo, (function foo) as #'foo, and, backquoted\n\
1940 forms print in the new syntax.");
1943 DEFVAR_LISP ("print-gensym", &Vprint_gensym
,
1944 "Non-nil means print uninterned symbols so they will read as uninterned.\n\
1945 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.\n\
1946 When the uninterned symbol appears within a recursive data structure\n\
1947 and the symbol appears more than once, in addition use the #N# and #N=\n\
1948 constructs as needed, so that multiple references to the same symbol are\n\
1949 shared once again when the text is read back.");
1950 Vprint_gensym
= Qnil
;
1952 DEFVAR_LISP ("print-circle", &Vprint_circle
,
1953 "*Non-nil means print recursive structures using #N= and #N# syntax.\n\
1954 If nil, printing proceeds recursively and may lead to\n\
1955 `max-lisp-eval-depth' being exceeded or an error may occur:\n\
1956 \"Apparently circular structure being printed.\" Also see\n\
1957 `print-length' and `print-level'.\n\
1958 If non-nil, shared substructures anywhere in the structure are printed\n\
1959 with `#N=' before the first occurrence (in the order of the print\n\
1960 representation) and `#N#' in place of each subsequent occurrence,\n\
1961 where N is a positive decimal integer.");
1962 Vprint_circle
= Qnil
;
1964 DEFVAR_LISP ("print-continuous-numbering", &Vprint_continuous_numbering
,
1965 "*Non-nil means keep numbering between several print functions.\n\
1966 See `print-gensym' nad `print-circle'. See also `print-number-table'.");
1967 Vprint_continuous_numbering
= Qnil
;
1969 DEFVAR_LISP ("print-number-table", &Vprint_number_table
,
1970 "A vector keeping the information of the current printed object.\n\
1971 This variable shouldn't be modified in Lisp level, but should be binded\n\
1972 with nil using let at the same position with `print-continuous-numbering',\n\
1973 so that the value of this variable can be freed after printing.");
1974 Vprint_number_table
= Qnil
;
1976 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
1977 staticpro (&Vprin1_to_string_buffer
);
1980 defsubr (&Sprin1_to_string
);
1981 defsubr (&Serror_message_string
);
1985 defsubr (&Swrite_char
);
1986 defsubr (&Sexternal_debugging_output
);
1988 Qexternal_debugging_output
= intern ("external-debugging-output");
1989 staticpro (&Qexternal_debugging_output
);
1991 Qprint_escape_newlines
= intern ("print-escape-newlines");
1992 staticpro (&Qprint_escape_newlines
);
1994 Qprint_escape_multibyte
= intern ("print-escape-multibyte");
1995 staticpro (&Qprint_escape_multibyte
);
1997 Qprint_escape_nonascii
= intern ("print-escape-nonascii");
1998 staticpro (&Qprint_escape_nonascii
);
2000 defsubr (&Swith_output_to_temp_buffer
);