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 Lisp_Object Vfloat_output_format
, Qfloat_output_format
;
45 /* Work around a problem that happens because math.h on hpux 7
46 defines two static variables--which, in Emacs, are not really static,
47 because `static' is defined as nothing. The problem is that they are
48 defined both here and in lread.c.
49 These macros prevent the name conflict. */
50 #if defined (HPUX) && !defined (HPUX8)
51 #define _MAXLDBL print_maxldbl
52 #define _NMAXLDBL print_nmaxldbl
61 /* Default to values appropriate for IEEE floating point. */
66 #define DBL_MANT_DIG 53
72 #define DBL_MIN 2.2250738585072014e-308
75 #ifdef DBL_MIN_REPLACEMENT
77 #define DBL_MIN DBL_MIN_REPLACEMENT
80 /* Define DOUBLE_DIGITS_BOUND, an upper bound on the number of decimal digits
81 needed to express a float without losing information.
82 The general-case formula is valid for the usual case, IEEE floating point,
83 but many compilers can't optimize the formula to an integer constant,
84 so make a special case for it. */
85 #if FLT_RADIX == 2 && DBL_MANT_DIG == 53
86 #define DOUBLE_DIGITS_BOUND 17 /* IEEE floating point */
88 #define DOUBLE_DIGITS_BOUND ((int) ceil (log10 (pow (FLT_RADIX, DBL_MANT_DIG))))
91 /* Avoid actual stack overflow in print. */
94 /* Detect most circularities to print finite output. */
95 #define PRINT_CIRCLE 200
96 Lisp_Object being_printed
[PRINT_CIRCLE
];
98 /* When printing into a buffer, first we put the text in this
99 block, then insert it all at once. */
102 /* Size allocated in print_buffer. */
103 int print_buffer_size
;
104 /* Chars stored in print_buffer. */
105 int print_buffer_pos
;
106 /* Bytes stored in print_buffer. */
107 int print_buffer_pos_byte
;
109 /* Maximum length of list to print in full; noninteger means
110 effectively infinity */
112 Lisp_Object Vprint_length
;
114 /* Maximum depth of list to print in full; noninteger means
115 effectively infinity. */
117 Lisp_Object Vprint_level
;
119 /* Nonzero means print newlines in strings as \n. */
121 int print_escape_newlines
;
123 /* Nonzero means to print single-byte non-ascii characters in strings as
126 int print_escape_nonascii
;
128 /* Nonzero means to print multibyte characters in strings as hex escapes. */
130 int print_escape_multibyte
;
132 Lisp_Object Qprint_escape_newlines
;
133 Lisp_Object Qprint_escape_multibyte
, Qprint_escape_nonascii
;
135 /* Nonzero means print (quote foo) forms as 'foo, etc. */
139 /* Non-nil means print #: before uninterned symbols. */
141 Lisp_Object Vprint_gensym
;
143 /* Non-nil means print recursive structures using #n= and #n# syntax. */
145 Lisp_Object Vprint_circle
;
147 /* Non-nil means keep continuous number for #n= and #n# syntax
148 between several print functions. */
150 Lisp_Object Vprint_continuous_numbering
;
152 /* Vprint_number_table is a vector like [OBJ1 STAT1 OBJ2 STAT2 ...],
153 where OBJn are objects going to be printed, and STATn are their status,
154 which may be different meanings during process. See the comments of
155 the functions print and print_preprocess for details.
156 print_number_index keeps the last position the next object should be added,
157 twice of which is the actual vector position in Vprint_number_table. */
158 int print_number_index
;
159 Lisp_Object Vprint_number_table
;
161 /* PRINT_NUMBER_OBJECT returns the I'th object in Vprint_number_table TABLE.
162 PRINT_NUMBER_STATUS returns the status of the I'th object in TABLE.
163 See the comment of the variable Vprint_number_table. */
164 #define PRINT_NUMBER_OBJECT(table,i) XVECTOR ((table))->contents[(i) * 2]
165 #define PRINT_NUMBER_STATUS(table,i) XVECTOR ((table))->contents[(i) * 2 + 1]
167 /* Nonzero means print newline to stdout before next minibuffer message.
168 Defined in xdisp.c */
170 extern int noninteractive_need_newline
;
172 extern int minibuffer_auto_raise
;
174 #ifdef MAX_PRINT_CHARS
175 static int print_chars
;
176 static int max_print
;
177 #endif /* MAX_PRINT_CHARS */
179 void print_interval ();
182 /* Low level output routines for characters and strings */
184 /* Lisp functions to do output using a stream
185 must have the stream in a variable called printcharfun
186 and must start with PRINTPREPARE, end with PRINTFINISH,
187 and use PRINTDECLARE to declare common variables.
188 Use PRINTCHAR to output one character,
189 or call strout to output a block of characters. */
191 #define PRINTDECLARE \
192 struct buffer *old = current_buffer; \
193 int old_point = -1, start_point; \
194 int old_point_byte, start_point_byte; \
195 int specpdl_count = specpdl_ptr - specpdl; \
196 int free_print_buffer = 0; \
197 int multibyte = !NILP (current_buffer->enable_multibyte_characters); \
200 #define PRINTPREPARE \
201 original = printcharfun; \
202 if (NILP (printcharfun)) printcharfun = Qt; \
203 if (BUFFERP (printcharfun)) \
205 if (XBUFFER (printcharfun) != current_buffer) \
206 Fset_buffer (printcharfun); \
207 printcharfun = Qnil; \
209 if (MARKERP (printcharfun)) \
211 if (!(XMARKER (original)->buffer)) \
212 error ("Marker does not point anywhere"); \
213 if (XMARKER (original)->buffer != current_buffer) \
214 set_buffer_internal (XMARKER (original)->buffer); \
216 old_point_byte = PT_BYTE; \
217 SET_PT_BOTH (marker_position (printcharfun), \
218 marker_byte_position (printcharfun)); \
220 start_point_byte = PT_BYTE; \
221 printcharfun = Qnil; \
223 if (NILP (printcharfun)) \
225 Lisp_Object string; \
226 if (NILP (current_buffer->enable_multibyte_characters) \
227 && ! print_escape_multibyte) \
228 specbind (Qprint_escape_multibyte, Qt); \
229 if (! NILP (current_buffer->enable_multibyte_characters) \
230 && ! print_escape_nonascii) \
231 specbind (Qprint_escape_nonascii, Qt); \
232 if (print_buffer != 0) \
234 string = make_string_from_bytes (print_buffer, \
236 print_buffer_pos_byte); \
237 record_unwind_protect (print_unwind, string); \
241 print_buffer_size = 1000; \
242 print_buffer = (char *) xmalloc (print_buffer_size); \
243 free_print_buffer = 1; \
245 print_buffer_pos = 0; \
246 print_buffer_pos_byte = 0; \
248 if (EQ (printcharfun, Qt) && ! noninteractive) \
249 setup_echo_area_for_printing (multibyte);
251 #define PRINTFINISH \
252 if (NILP (printcharfun)) \
254 if (print_buffer_pos != print_buffer_pos_byte \
255 && NILP (current_buffer->enable_multibyte_characters)) \
257 unsigned char *temp \
258 = (unsigned char *) alloca (print_buffer_pos + 1); \
259 copy_text (print_buffer, temp, print_buffer_pos_byte, \
261 insert_1_both (temp, print_buffer_pos, \
262 print_buffer_pos, 0, 1, 0); \
265 insert_1_both (print_buffer, print_buffer_pos, \
266 print_buffer_pos_byte, 0, 1, 0); \
268 if (free_print_buffer) \
270 xfree (print_buffer); \
273 unbind_to (specpdl_count, Qnil); \
274 if (MARKERP (original)) \
275 set_marker_both (original, Qnil, PT, PT_BYTE); \
276 if (old_point >= 0) \
277 SET_PT_BOTH (old_point + (old_point >= start_point \
278 ? PT - start_point : 0), \
279 old_point_byte + (old_point_byte >= start_point_byte \
280 ? PT_BYTE - start_point_byte : 0)); \
281 if (old != current_buffer) \
282 set_buffer_internal (old);
284 #define PRINTCHAR(ch) printchar (ch, printcharfun)
286 /* This is used to restore the saved contents of print_buffer
287 when there is a recursive call to print. */
290 print_unwind (saved_text
)
291 Lisp_Object saved_text
;
293 bcopy (XSTRING (saved_text
)->data
, print_buffer
, XSTRING (saved_text
)->size
);
297 /* Print character CH using method FUN. FUN nil means print to
298 print_buffer. FUN t means print to echo area or stdout if
299 non-interactive. If FUN is neither nil nor t, call FUN with CH as
307 #ifdef MAX_PRINT_CHARS
310 #endif /* MAX_PRINT_CHARS */
312 if (!NILP (fun
) && !EQ (fun
, Qt
))
313 call1 (fun
, make_number (ch
));
316 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
317 int len
= CHAR_STRING (ch
, str
);
323 if (print_buffer_pos_byte
+ len
>= print_buffer_size
)
324 print_buffer
= (char *) xrealloc (print_buffer
,
325 print_buffer_size
*= 2);
326 bcopy (str
, print_buffer
+ print_buffer_pos_byte
, len
);
327 print_buffer_pos
+= 1;
328 print_buffer_pos_byte
+= len
;
330 else if (noninteractive
)
332 fwrite (str
, 1, len
, stdout
);
333 noninteractive_need_newline
= 1;
338 = !NILP (current_buffer
->enable_multibyte_characters
);
340 if (!message_buf_print
)
341 setup_echo_area_for_printing (multibyte_p
);
344 message_dolog (str
, len
, 0, multibyte_p
);
350 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
351 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
352 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
353 print_buffer. PRINTCHARFUN t means output to the echo area or to
354 stdout if non-interactive. If neither nil nor t, call Lisp
355 function PRINTCHARFUN for each character printed. MULTIBYTE
356 non-zero means PTR contains multibyte characters. */
359 strout (ptr
, size
, size_byte
, printcharfun
, multibyte
)
362 Lisp_Object printcharfun
;
366 size_byte
= size
= strlen (ptr
);
368 if (NILP (printcharfun
))
370 if (print_buffer_pos_byte
+ size_byte
> print_buffer_size
)
372 print_buffer_size
= print_buffer_size
* 2 + size_byte
;
373 print_buffer
= (char *) xrealloc (print_buffer
,
376 bcopy (ptr
, print_buffer
+ print_buffer_pos_byte
, size_byte
);
377 print_buffer_pos
+= size
;
378 print_buffer_pos_byte
+= size_byte
;
380 #ifdef MAX_PRINT_CHARS
383 #endif /* MAX_PRINT_CHARS */
385 else if (noninteractive
&& EQ (printcharfun
, Qt
))
387 fwrite (ptr
, 1, size_byte
, stdout
);
388 noninteractive_need_newline
= 1;
390 else if (EQ (printcharfun
, Qt
))
392 /* Output to echo area. We're trying to avoid a little overhead
393 here, that's the reason we don't call printchar to do the
397 = !NILP (current_buffer
->enable_multibyte_characters
);
399 if (!message_buf_print
)
400 setup_echo_area_for_printing (multibyte_p
);
402 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
404 if (size
== size_byte
)
406 for (i
= 0; i
< size
; ++i
)
407 insert_char (*ptr
++);
412 for (i
= 0; i
< size_byte
; i
+= len
)
414 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size_byte
- i
, len
);
419 #ifdef MAX_PRINT_CHARS
422 #endif /* MAX_PRINT_CHARS */
426 /* PRINTCHARFUN is a Lisp function. */
429 if (size
== size_byte
)
431 while (i
< size_byte
)
439 while (i
< size_byte
)
441 /* Here, we must convert each multi-byte form to the
442 corresponding character code before handing it to
445 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size_byte
- i
, len
);
453 /* Print the contents of a string STRING using PRINTCHARFUN.
454 It isn't safe to use strout in many cases,
455 because printing one char can relocate. */
458 print_string (string
, printcharfun
)
460 Lisp_Object printcharfun
;
462 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
466 if (STRING_MULTIBYTE (string
))
467 chars
= XSTRING (string
)->size
;
468 else if (EQ (printcharfun
, Qt
)
469 ? ! NILP (buffer_defaults
.enable_multibyte_characters
)
470 : ! NILP (current_buffer
->enable_multibyte_characters
))
471 chars
= multibyte_chars_in_text (XSTRING (string
)->data
,
472 STRING_BYTES (XSTRING (string
)));
474 chars
= STRING_BYTES (XSTRING (string
));
476 /* strout is safe for output to a frame (echo area) or to print_buffer. */
477 strout (XSTRING (string
)->data
,
478 chars
, STRING_BYTES (XSTRING (string
)),
479 printcharfun
, STRING_MULTIBYTE (string
));
483 /* Otherwise, string may be relocated by printing one char.
484 So re-fetch the string address for each character. */
486 int size
= XSTRING (string
)->size
;
487 int size_byte
= STRING_BYTES (XSTRING (string
));
490 if (size
== size_byte
)
491 for (i
= 0; i
< size
; i
++)
492 PRINTCHAR (XSTRING (string
)->data
[i
]);
494 for (i
= 0; i
< size_byte
; i
++)
496 /* Here, we must convert each multi-byte form to the
497 corresponding character code before handing it to PRINTCHAR. */
499 int ch
= STRING_CHAR_AND_LENGTH (XSTRING (string
)->data
+ i
,
501 if (!CHAR_VALID_P (ch
, 0))
503 ch
= XSTRING (string
)->data
[i
];
513 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
514 "Output character CHARACTER to stream PRINTCHARFUN.\n\
515 PRINTCHARFUN defaults to the value of `standard-output' (which see).")
516 (character
, printcharfun
)
517 Lisp_Object character
, printcharfun
;
521 if (NILP (printcharfun
))
522 printcharfun
= Vstandard_output
;
523 CHECK_NUMBER (character
, 0);
525 PRINTCHAR (XINT (character
));
530 /* Used from outside of print.c to print a block of SIZE
531 single-byte chars at DATA on the default output stream.
532 Do not use this on the contents of a Lisp string. */
535 write_string (data
, size
)
540 Lisp_Object printcharfun
;
542 printcharfun
= Vstandard_output
;
545 strout (data
, size
, size
, printcharfun
, 0);
549 /* Used from outside of print.c to print a block of SIZE
550 single-byte chars at DATA on a specified stream PRINTCHARFUN.
551 Do not use this on the contents of a Lisp string. */
554 write_string_1 (data
, size
, printcharfun
)
557 Lisp_Object printcharfun
;
562 strout (data
, size
, size
, printcharfun
, 0);
568 temp_output_buffer_setup (bufname
)
571 int count
= specpdl_ptr
- specpdl
;
572 register struct buffer
*old
= current_buffer
;
573 register Lisp_Object buf
;
575 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
577 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
579 current_buffer
->directory
= old
->directory
;
580 current_buffer
->read_only
= Qnil
;
581 current_buffer
->filename
= Qnil
;
582 current_buffer
->undo_list
= Qt
;
583 current_buffer
->overlays_before
= Qnil
;
584 current_buffer
->overlays_after
= Qnil
;
585 current_buffer
->enable_multibyte_characters
586 = buffer_defaults
.enable_multibyte_characters
;
588 XSETBUFFER (buf
, current_buffer
);
590 call1 (Vrun_hooks
, Qtemp_buffer_setup_hook
);
592 unbind_to (count
, Qnil
);
594 specbind (Qstandard_output
, buf
);
598 internal_with_output_to_temp_buffer (bufname
, function
, args
)
600 Lisp_Object (*function
) P_ ((Lisp_Object
));
603 int count
= specpdl_ptr
- specpdl
;
604 Lisp_Object buf
, val
;
608 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
609 temp_output_buffer_setup (bufname
);
610 buf
= Vstandard_output
;
613 val
= (*function
) (args
);
616 temp_output_buffer_show (buf
);
619 return unbind_to (count
, val
);
622 DEFUN ("with-output-to-temp-buffer", Fwith_output_to_temp_buffer
, Swith_output_to_temp_buffer
,
624 "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.\n\
625 The buffer is cleared out initially, and marked as unmodified when done.\n\
626 All output done by BODY is inserted in that buffer by default.\n\
627 The buffer is displayed in another window, but not selected.\n\
628 The value of the last form in BODY is returned.\n\
629 If BODY does not finish normally, the buffer BUFNAME is not displayed.\n\
631 The hook `temp-buffer-setup-hook' is run before BODY,\n\
632 with the buffer BUFNAME temporarily current.\n\
633 The hook `temp-buffer-show-hook' is run after the buffer is displayed,\n\
634 with the buffer temporarily current, and the window that was used\n\
635 to display it temporarily selected.\n\
637 If variable `temp-buffer-show-function' is non-nil, call it at the end\n\
638 to get the buffer displayed instead of just displaying the non-selected\n\
639 buffer and calling the hook. It gets one argument, the buffer to display.")
645 int count
= specpdl_ptr
- specpdl
;
646 Lisp_Object buf
, val
;
649 name
= Feval (Fcar (args
));
652 CHECK_STRING (name
, 0);
653 temp_output_buffer_setup (XSTRING (name
)->data
);
654 buf
= Vstandard_output
;
656 val
= Fprogn (Fcdr (args
));
658 temp_output_buffer_show (buf
);
660 return unbind_to (count
, val
);
664 static void print ();
665 static void print_preprocess ();
666 static void print_preprocess_string ();
667 static void print_object ();
669 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
670 "Output a newline to stream PRINTCHARFUN.\n\
671 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used.")
673 Lisp_Object printcharfun
;
677 if (NILP (printcharfun
))
678 printcharfun
= Vstandard_output
;
685 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
686 "Output the printed representation of OBJECT, any Lisp object.\n\
687 Quoting characters are printed when needed to make output that `read'\n\
688 can handle, whenever this is possible.\n\
689 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
690 (object
, printcharfun
)
691 Lisp_Object object
, printcharfun
;
695 #ifdef MAX_PRINT_CHARS
697 #endif /* MAX_PRINT_CHARS */
698 if (NILP (printcharfun
))
699 printcharfun
= Vstandard_output
;
701 print (object
, printcharfun
, 1);
706 /* a buffer which is used to hold output being built by prin1-to-string */
707 Lisp_Object Vprin1_to_string_buffer
;
709 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
710 "Return a string containing the printed representation of OBJECT,\n\
711 any Lisp object. Quoting characters are used when needed to make output\n\
712 that `read' can handle, whenever this is possible, unless the optional\n\
713 second argument NOESCAPE is non-nil.")
715 Lisp_Object object
, noescape
;
718 Lisp_Object printcharfun
;
719 struct gcpro gcpro1
, gcpro2
;
722 /* Save and restore this--we are altering a buffer
723 but we don't want to deactivate the mark just for that.
724 No need for specbind, since errors deactivate the mark. */
725 tem
= Vdeactivate_mark
;
726 GCPRO2 (object
, tem
);
728 printcharfun
= Vprin1_to_string_buffer
;
730 print (object
, printcharfun
, NILP (noescape
));
731 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
733 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
734 object
= Fbuffer_string ();
737 set_buffer_internal (old
);
739 Vdeactivate_mark
= tem
;
745 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
746 "Output the printed representation of OBJECT, any Lisp object.\n\
747 No quoting characters are used; no delimiters are printed around\n\
748 the contents of strings.\n\
749 Output stream is PRINTCHARFUN, or value of standard-output (which see).")
750 (object
, printcharfun
)
751 Lisp_Object object
, printcharfun
;
755 if (NILP (printcharfun
))
756 printcharfun
= Vstandard_output
;
758 print (object
, printcharfun
, 0);
763 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
764 "Output the printed representation of OBJECT, with newlines around it.\n\
765 Quoting characters are printed when needed to make output that `read'\n\
766 can handle, whenever this is possible.\n\
767 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
768 (object
, printcharfun
)
769 Lisp_Object object
, printcharfun
;
774 #ifdef MAX_PRINT_CHARS
776 max_print
= MAX_PRINT_CHARS
;
777 #endif /* MAX_PRINT_CHARS */
778 if (NILP (printcharfun
))
779 printcharfun
= Vstandard_output
;
783 print (object
, printcharfun
, 1);
786 #ifdef MAX_PRINT_CHARS
789 #endif /* MAX_PRINT_CHARS */
794 /* The subroutine object for external-debugging-output is kept here
795 for the convenience of the debugger. */
796 Lisp_Object Qexternal_debugging_output
;
798 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
799 "Write CHARACTER to stderr.\n\
800 You can call print while debugging emacs, and pass it this function\n\
801 to make it write to the debugging output.\n")
803 Lisp_Object character
;
805 CHECK_NUMBER (character
, 0);
806 putc (XINT (character
), stderr
);
809 /* Send the output to a debugger (nothing happens if there isn't one). */
811 char buf
[2] = {(char) XINT (character
), '\0'};
812 OutputDebugString (buf
);
819 /* This is the interface for debugging printing. */
825 Fprin1 (arg
, Qexternal_debugging_output
);
826 fprintf (stderr
, "\r\n");
829 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
831 "Convert an error value (ERROR-SYMBOL . DATA) to an error message.")
835 struct buffer
*old
= current_buffer
;
839 /* If OBJ is (error STRING), just return STRING.
840 That is not only faster, it also avoids the need to allocate
841 space here when the error is due to memory full. */
842 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
843 && CONSP (XCDR (obj
))
844 && STRINGP (XCAR (XCDR (obj
)))
845 && NILP (XCDR (XCDR (obj
))))
846 return XCAR (XCDR (obj
));
848 print_error_message (obj
, Vprin1_to_string_buffer
);
850 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
851 value
= Fbuffer_string ();
855 set_buffer_internal (old
);
861 /* Print an error message for the error DATA onto Lisp output stream
862 STREAM (suitable for the print functions). */
865 print_error_message (data
, stream
)
866 Lisp_Object data
, stream
;
868 Lisp_Object errname
, errmsg
, file_error
, tail
;
872 errname
= Fcar (data
);
874 if (EQ (errname
, Qerror
))
879 errmsg
= Fcar (data
);
884 Lisp_Object error_conditions
;
885 errmsg
= Fget (errname
, Qerror_message
);
886 error_conditions
= Fget (errname
, Qerror_conditions
);
887 file_error
= Fmemq (Qfile_error
, error_conditions
);
890 /* Print an error message including the data items. */
892 tail
= Fcdr_safe (data
);
895 /* For file-error, make error message by concatenating
896 all the data items. They are all strings. */
897 if (!NILP (file_error
) && CONSP (tail
))
898 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
900 if (STRINGP (errmsg
))
901 Fprinc (errmsg
, stream
);
903 write_string_1 ("peculiar error", -1, stream
);
905 for (i
= 0; CONSP (tail
); tail
= XCDR (tail
), i
++)
909 write_string_1 (i
? ", " : ": ", 2, stream
);
911 if (!NILP (file_error
) || EQ (errname
, Qend_of_file
))
912 Fprinc (obj
, stream
);
914 Fprin1 (obj
, stream
);
923 * The buffer should be at least as large as the max string size of the
924 * largest float, printed in the biggest notation. This is undoubtedly
925 * 20d float_output_format, with the negative of the C-constant "HUGE"
928 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
930 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
931 * case of -1e307 in 20d float_output_format. What is one to do (short of
932 * re-writing _doprnt to be more sane)?
937 float_to_string (buf
, data
)
944 /* Check for plus infinity in a way that won't lose
945 if there is no plus infinity. */
946 if (data
== data
/ 2 && data
> 1.0)
948 strcpy (buf
, "1.0e+INF");
951 /* Likewise for minus infinity. */
952 if (data
== data
/ 2 && data
< -1.0)
954 strcpy (buf
, "-1.0e+INF");
957 /* Check for NaN in a way that won't fail if there are no NaNs. */
958 if (! (data
* 0.0 >= 0.0))
960 /* Prepend "-" if the NaN's sign bit is negative.
961 The sign bit of a double is the bit that is 1 in -0.0. */
963 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
965 u_minus_zero
.d
= - 0.0;
966 for (i
= 0; i
< sizeof (double); i
++)
967 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
973 strcpy (buf
, "0.0e+NaN");
977 if (NILP (Vfloat_output_format
)
978 || !STRINGP (Vfloat_output_format
))
981 /* Generate the fewest number of digits that represent the
982 floating point value without losing information.
983 The following method is simple but a bit slow.
984 For ideas about speeding things up, please see:
986 Guy L Steele Jr & Jon L White, How to print floating-point numbers
987 accurately. SIGPLAN notices 25, 6 (June 1990), 112-126.
989 Robert G Burger & R Kent Dybvig, Printing floating point numbers
990 quickly and accurately, SIGPLAN notices 31, 5 (May 1996), 108-116. */
992 width
= fabs (data
) < DBL_MIN
? 1 : DBL_DIG
;
994 sprintf (buf
, "%.*g", width
, data
);
995 while (width
++ < DOUBLE_DIGITS_BOUND
&& atof (buf
) != data
);
999 /* Check that the spec we have is fully valid.
1000 This means not only valid for printf,
1001 but meant for floats, and reasonable. */
1002 cp
= XSTRING (Vfloat_output_format
)->data
;
1011 /* Check the width specification. */
1013 if ('0' <= *cp
&& *cp
<= '9')
1017 width
= (width
* 10) + (*cp
++ - '0');
1018 while (*cp
>= '0' && *cp
<= '9');
1020 /* A precision of zero is valid only for %f. */
1022 || (width
== 0 && *cp
!= 'f'))
1026 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1032 sprintf (buf
, XSTRING (Vfloat_output_format
)->data
, data
);
1035 /* Make sure there is a decimal point with digit after, or an
1036 exponent, so that the value is readable as a float. But don't do
1037 this with "%.0f"; it's valid for that not to produce a decimal
1038 point. Note that width can be 0 only for %.0f. */
1041 for (cp
= buf
; *cp
; cp
++)
1042 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1045 if (*cp
== '.' && cp
[1] == 0)
1062 print (obj
, printcharfun
, escapeflag
)
1064 register Lisp_Object printcharfun
;
1069 /* Reset print_number_index and Vprint_number_table only when
1070 the variable Vprint_continuous_numbering is nil. Otherwise,
1071 the values of these variables will be kept between several
1073 if (NILP (Vprint_continuous_numbering
))
1075 print_number_index
= 0;
1076 Vprint_number_table
= Qnil
;
1079 /* Construct Vprint_number_table for print-gensym and print-circle. */
1080 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1082 int i
, start
, index
;
1083 /* Construct Vprint_number_table. */
1084 start
= index
= print_number_index
;
1085 print_preprocess (obj
);
1086 /* Remove unnecessary objects, which appear only once in OBJ;
1087 that is, whose status is Qnil. */
1088 for (i
= start
; i
< print_number_index
; i
++)
1089 if (!NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1091 PRINT_NUMBER_OBJECT (Vprint_number_table
, index
)
1092 = PRINT_NUMBER_OBJECT (Vprint_number_table
, i
);
1093 /* Reset the status field for the next print step. Now this
1094 field means whether the object has already been printed. */
1095 PRINT_NUMBER_STATUS (Vprint_number_table
, index
) = Qnil
;
1098 print_number_index
= index
;
1101 print_object (obj
, printcharfun
, escapeflag
);
1104 /* Construct Vprint_number_table according to the structure of OBJ.
1105 OBJ itself and all its elements will be added to Vprint_number_table
1106 recursively if it is a list, vector, compiled function, char-table,
1107 string (its text properties will be traced), or a symbol that has
1108 no obarray (this is for the print-gensym feature).
1109 The status fields of Vprint_number_table mean whether each object appears
1110 more than once in OBJ: Qnil at the first time, and Qt after that . */
1112 print_preprocess (obj
)
1118 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1119 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
)
1120 || (! NILP (Vprint_gensym
)
1121 && SYMBOLP (obj
) && NILP (XSYMBOL (obj
)->obarray
)))
1123 /* In case print-circle is nil and print-gensym is t,
1124 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1125 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1127 for (i
= 0; i
< print_number_index
; i
++)
1128 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
), obj
))
1130 /* OBJ appears more than once. Let's remember that. */
1131 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1135 /* OBJ is not yet recorded. Let's add to the table. */
1136 if (print_number_index
== 0)
1138 /* Initialize the table. */
1139 Vprint_number_table
= Fmake_vector (make_number (40), Qnil
);
1141 else if (XVECTOR (Vprint_number_table
)->size
== print_number_index
* 2)
1143 /* Reallocate the table. */
1144 int i
= print_number_index
* 4;
1145 Lisp_Object old_table
= Vprint_number_table
;
1146 Vprint_number_table
= Fmake_vector (make_number (i
), Qnil
);
1147 for (i
= 0; i
< print_number_index
; i
++)
1149 PRINT_NUMBER_OBJECT (Vprint_number_table
, i
)
1150 = PRINT_NUMBER_OBJECT (old_table
, i
);
1151 PRINT_NUMBER_STATUS (Vprint_number_table
, i
)
1152 = PRINT_NUMBER_STATUS (old_table
, i
);
1155 PRINT_NUMBER_OBJECT (Vprint_number_table
, print_number_index
) = obj
;
1156 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1157 always print the gensym with a number. This is a special for
1158 the lisp function byte-compile-output-docform. */
1159 if (! NILP (Vprint_continuous_numbering
) && SYMBOLP (obj
)
1160 && NILP (XSYMBOL (obj
)->obarray
))
1161 PRINT_NUMBER_STATUS (Vprint_number_table
, print_number_index
) = Qt
;
1162 print_number_index
++;
1165 switch (XGCTYPE (obj
))
1168 /* A string may have text properties, which can be circular. */
1169 traverse_intervals (XSTRING (obj
)->intervals
, 0, 0,
1170 print_preprocess_string
, Qnil
);
1174 print_preprocess (XCAR (obj
));
1178 case Lisp_Vectorlike
:
1179 size
= XVECTOR (obj
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1180 for (i
= 0; i
< size
; i
++)
1181 print_preprocess (XVECTOR (obj
)->contents
[i
]);
1187 print_preprocess_string (interval
, arg
)
1191 print_preprocess (interval
->plist
);
1195 print_object (obj
, printcharfun
, escapeflag
)
1197 register Lisp_Object printcharfun
;
1204 /* Detect circularities and truncate them. */
1205 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1206 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
)
1207 || (! NILP (Vprint_gensym
)
1208 && SYMBOLP (obj
) && NILP (XSYMBOL (obj
)->obarray
)))
1210 if (NILP (Vprint_circle
) && NILP (Vprint_gensym
))
1212 /* Simple but incomplete way. */
1214 for (i
= 0; i
< print_depth
; i
++)
1215 if (EQ (obj
, being_printed
[i
]))
1217 sprintf (buf
, "#%d", i
);
1218 strout (buf
, -1, -1, printcharfun
, 0);
1221 being_printed
[print_depth
] = obj
;
1225 /* With the print-circle feature. */
1227 for (i
= 0; i
< print_number_index
; i
++)
1228 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
), obj
))
1230 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1232 /* Add a prefix #n= if OBJ has not yet been printed;
1233 that is, its status field is nil. */
1234 sprintf (buf
, "#%d=", i
+ 1);
1235 strout (buf
, -1, -1, printcharfun
, 0);
1236 /* OBJ is going to be printed. Set the status to t. */
1237 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1242 /* Just print #n# if OBJ has already been printed. */
1243 sprintf (buf
, "#%d#", i
+ 1);
1244 strout (buf
, -1, -1, printcharfun
, 0);
1253 if (print_depth
> PRINT_CIRCLE
)
1254 error ("Apparently circular structure being printed");
1255 #ifdef MAX_PRINT_CHARS
1256 if (max_print
&& print_chars
> max_print
)
1261 #endif /* MAX_PRINT_CHARS */
1263 switch (XGCTYPE (obj
))
1266 if (sizeof (int) == sizeof (EMACS_INT
))
1267 sprintf (buf
, "%d", XINT (obj
));
1268 else if (sizeof (long) == sizeof (EMACS_INT
))
1269 sprintf (buf
, "%ld", (long) XINT (obj
));
1272 strout (buf
, -1, -1, printcharfun
, 0);
1277 char pigbuf
[350]; /* see comments in float_to_string */
1279 float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1280 strout (pigbuf
, -1, -1, printcharfun
, 0);
1286 print_string (obj
, printcharfun
);
1289 register int i
, i_byte
;
1290 struct gcpro gcpro1
;
1293 /* 1 means we must ensure that the next character we output
1294 cannot be taken as part of a hex character escape. */
1295 int need_nonhex
= 0;
1299 if (!NULL_INTERVAL_P (XSTRING (obj
)->intervals
))
1306 str
= XSTRING (obj
)->data
;
1307 size_byte
= STRING_BYTES (XSTRING (obj
));
1309 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1311 /* Here, we must convert each multi-byte form to the
1312 corresponding character code before handing it to PRINTCHAR. */
1316 if (STRING_MULTIBYTE (obj
))
1318 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
,
1319 size_byte
- i_byte
, len
);
1320 if (CHAR_VALID_P (c
, 0))
1330 if (c
== '\n' && print_escape_newlines
)
1335 else if (c
== '\f' && print_escape_newlines
)
1340 else if (! SINGLE_BYTE_CHAR_P (c
) && print_escape_multibyte
)
1342 /* When multibyte is disabled,
1343 print multibyte string chars using hex escapes. */
1344 unsigned char outbuf
[50];
1345 sprintf (outbuf
, "\\x%x", c
);
1346 strout (outbuf
, -1, -1, printcharfun
, 0);
1349 else if (SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1350 && print_escape_nonascii
)
1352 /* When printing in a multibyte buffer
1353 or when explicitly requested,
1354 print single-byte non-ASCII string chars
1355 using octal escapes. */
1356 unsigned char outbuf
[5];
1357 sprintf (outbuf
, "\\%03o", c
);
1358 strout (outbuf
, -1, -1, printcharfun
, 0);
1362 /* If we just had a hex escape, and this character
1363 could be taken as part of it,
1364 output `\ ' to prevent that. */
1368 if ((c
>= 'a' && c
<= 'f')
1369 || (c
>= 'A' && c
<= 'F')
1370 || (c
>= '0' && c
<= '9'))
1371 strout ("\\ ", -1, -1, printcharfun
, 0);
1374 if (c
== '\"' || c
== '\\')
1381 if (!NULL_INTERVAL_P (XSTRING (obj
)->intervals
))
1383 traverse_intervals (XSTRING (obj
)->intervals
,
1384 0, 0, print_interval
, printcharfun
);
1394 register int confusing
;
1395 register unsigned char *p
= XSYMBOL (obj
)->name
->data
;
1396 register unsigned char *end
= p
+ STRING_BYTES (XSYMBOL (obj
)->name
);
1398 int i
, i_byte
, size_byte
;
1401 XSETSTRING (name
, XSYMBOL (obj
)->name
);
1403 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1406 /* If symbol name begins with a digit, and ends with a digit,
1407 and contains nothing but digits and `e', it could be treated
1408 as a number. So set CONFUSING.
1410 Symbols that contain periods could also be taken as numbers,
1411 but periods are always escaped, so we don't have to worry
1413 else if (*p
>= '0' && *p
<= '9'
1414 && end
[-1] >= '0' && end
[-1] <= '9')
1416 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1417 /* Needed for \2e10. */
1420 confusing
= (end
== p
);
1425 if (! NILP (Vprint_gensym
) && NILP (XSYMBOL (obj
)->obarray
))
1431 size_byte
= STRING_BYTES (XSTRING (name
));
1433 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1435 /* Here, we must convert each multi-byte form to the
1436 corresponding character code before handing it to PRINTCHAR. */
1437 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1442 if (c
== '\"' || c
== '\\' || c
== '\''
1443 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1444 || c
== ',' || c
=='.' || c
== '`'
1445 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1447 PRINTCHAR ('\\'), confusing
= 0;
1455 /* If deeper than spec'd depth, print placeholder. */
1456 if (INTEGERP (Vprint_level
)
1457 && print_depth
> XINT (Vprint_level
))
1458 strout ("...", -1, -1, printcharfun
, 0);
1459 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1460 && (EQ (XCAR (obj
), Qquote
)))
1463 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1465 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1466 && (EQ (XCAR (obj
), Qfunction
)))
1470 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1472 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1473 && ((EQ (XCAR (obj
), Qbackquote
)
1474 || EQ (XCAR (obj
), Qcomma
)
1475 || EQ (XCAR (obj
), Qcomma_at
)
1476 || EQ (XCAR (obj
), Qcomma_dot
))))
1478 print_object (XCAR (obj
), printcharfun
, 0);
1479 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1485 int print_length
, i
;
1486 Lisp_Object halftail
= obj
;
1488 /* Negative values of print-length are invalid in CL.
1489 Treat them like nil, as CMUCL does. */
1490 if (NATNUMP (Vprint_length
))
1491 print_length
= XFASTINT (Vprint_length
);
1498 /* Detect circular list. */
1499 if (NILP (Vprint_circle
))
1501 /* Simple but imcomplete way. */
1502 if (i
!= 0 && EQ (obj
, halftail
))
1504 sprintf (buf
, " . #%d", i
/ 2);
1505 strout (buf
, -1, -1, printcharfun
, 0);
1511 /* With the print-circle feature. */
1515 for (i
= 0; i
< print_number_index
; i
++)
1516 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
),
1519 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1521 strout (" . ", 3, 3, printcharfun
, 0);
1522 print_object (obj
, printcharfun
, escapeflag
);
1526 sprintf (buf
, " . #%d#", i
+ 1);
1527 strout (buf
, -1, -1, printcharfun
, 0);
1537 if (print_length
&& i
> print_length
)
1539 strout ("...", 3, 3, printcharfun
, 0);
1543 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1547 halftail
= XCDR (halftail
);
1551 /* OBJ non-nil here means it's the end of a dotted list. */
1554 strout (" . ", 3, 3, printcharfun
, 0);
1555 print_object (obj
, printcharfun
, escapeflag
);
1563 case Lisp_Vectorlike
:
1568 strout ("#<process ", -1, -1, printcharfun
, 0);
1569 print_string (XPROCESS (obj
)->name
, printcharfun
);
1573 print_string (XPROCESS (obj
)->name
, printcharfun
);
1575 else if (BOOL_VECTOR_P (obj
))
1578 register unsigned char c
;
1579 struct gcpro gcpro1
;
1581 = (XBOOL_VECTOR (obj
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1587 sprintf (buf
, "%d", XBOOL_VECTOR (obj
)->size
);
1588 strout (buf
, -1, -1, printcharfun
, 0);
1591 /* Don't print more characters than the specified maximum.
1592 Negative values of print-length are invalid. Treat them
1593 like a print-length of nil. */
1594 if (NATNUMP (Vprint_length
)
1595 && XFASTINT (Vprint_length
) < size_in_chars
)
1596 size_in_chars
= XFASTINT (Vprint_length
);
1598 for (i
= 0; i
< size_in_chars
; i
++)
1601 c
= XBOOL_VECTOR (obj
)->data
[i
];
1602 if (c
== '\n' && print_escape_newlines
)
1607 else if (c
== '\f' && print_escape_newlines
)
1614 if (c
== '\"' || c
== '\\')
1623 else if (SUBRP (obj
))
1625 strout ("#<subr ", -1, -1, printcharfun
, 0);
1626 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
, 0);
1629 else if (WINDOWP (obj
))
1631 strout ("#<window ", -1, -1, printcharfun
, 0);
1632 sprintf (buf
, "%d", XFASTINT (XWINDOW (obj
)->sequence_number
));
1633 strout (buf
, -1, -1, printcharfun
, 0);
1634 if (!NILP (XWINDOW (obj
)->buffer
))
1636 strout (" on ", -1, -1, printcharfun
, 0);
1637 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1641 else if (HASH_TABLE_P (obj
))
1643 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1644 strout ("#<hash-table", -1, -1, printcharfun
, 0);
1645 if (SYMBOLP (h
->test
))
1649 strout (XSYMBOL (h
->test
)->name
->data
, -1, -1, printcharfun
, 0);
1651 strout (XSYMBOL (h
->weak
)->name
->data
, -1, -1, printcharfun
, 0);
1653 sprintf (buf
, "%d/%d", XFASTINT (h
->count
),
1654 XVECTOR (h
->next
)->size
);
1655 strout (buf
, -1, -1, printcharfun
, 0);
1657 sprintf (buf
, " 0x%lx", (unsigned long) h
);
1658 strout (buf
, -1, -1, printcharfun
, 0);
1661 else if (BUFFERP (obj
))
1663 if (NILP (XBUFFER (obj
)->name
))
1664 strout ("#<killed buffer>", -1, -1, printcharfun
, 0);
1665 else if (escapeflag
)
1667 strout ("#<buffer ", -1, -1, printcharfun
, 0);
1668 print_string (XBUFFER (obj
)->name
, printcharfun
);
1672 print_string (XBUFFER (obj
)->name
, printcharfun
);
1674 else if (WINDOW_CONFIGURATIONP (obj
))
1676 strout ("#<window-configuration>", -1, -1, printcharfun
, 0);
1678 else if (FRAMEP (obj
))
1680 strout ((FRAME_LIVE_P (XFRAME (obj
))
1681 ? "#<frame " : "#<dead frame "),
1682 -1, -1, printcharfun
, 0);
1683 print_string (XFRAME (obj
)->name
, printcharfun
);
1684 sprintf (buf
, " 0x%lx\\ ", (unsigned long) (XFRAME (obj
)));
1685 strout (buf
, -1, -1, printcharfun
, 0);
1690 int size
= XVECTOR (obj
)->size
;
1691 if (COMPILEDP (obj
))
1694 size
&= PSEUDOVECTOR_SIZE_MASK
;
1696 if (CHAR_TABLE_P (obj
))
1698 /* We print a char-table as if it were a vector,
1699 lumping the parent and default slots in with the
1700 character slots. But we add #^ as a prefix. */
1703 if (SUB_CHAR_TABLE_P (obj
))
1705 size
&= PSEUDOVECTOR_SIZE_MASK
;
1707 if (size
& PSEUDOVECTOR_FLAG
)
1713 register Lisp_Object tem
;
1715 /* Don't print more elements than the specified maximum. */
1716 if (NATNUMP (Vprint_length
)
1717 && XFASTINT (Vprint_length
) < size
)
1718 size
= XFASTINT (Vprint_length
);
1720 for (i
= 0; i
< size
; i
++)
1722 if (i
) PRINTCHAR (' ');
1723 tem
= XVECTOR (obj
)->contents
[i
];
1724 print_object (tem
, printcharfun
, escapeflag
);
1732 switch (XMISCTYPE (obj
))
1734 case Lisp_Misc_Marker
:
1735 strout ("#<marker ", -1, -1, printcharfun
, 0);
1736 /* Do you think this is necessary? */
1737 if (XMARKER (obj
)->insertion_type
!= 0)
1738 strout ("(before-insertion) ", -1, -1, printcharfun
, 0);
1739 if (!(XMARKER (obj
)->buffer
))
1740 strout ("in no buffer", -1, -1, printcharfun
, 0);
1743 sprintf (buf
, "at %d", marker_position (obj
));
1744 strout (buf
, -1, -1, printcharfun
, 0);
1745 strout (" in ", -1, -1, printcharfun
, 0);
1746 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
1751 case Lisp_Misc_Overlay
:
1752 strout ("#<overlay ", -1, -1, printcharfun
, 0);
1753 if (!(XMARKER (OVERLAY_START (obj
))->buffer
))
1754 strout ("in no buffer", -1, -1, printcharfun
, 0);
1757 sprintf (buf
, "from %d to %d in ",
1758 marker_position (OVERLAY_START (obj
)),
1759 marker_position (OVERLAY_END (obj
)));
1760 strout (buf
, -1, -1, printcharfun
, 0);
1761 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
1767 /* Remaining cases shouldn't happen in normal usage, but let's print
1768 them anyway for the benefit of the debugger. */
1769 case Lisp_Misc_Free
:
1770 strout ("#<misc free cell>", -1, -1, printcharfun
, 0);
1773 case Lisp_Misc_Intfwd
:
1774 sprintf (buf
, "#<intfwd to %d>", *XINTFWD (obj
)->intvar
);
1775 strout (buf
, -1, -1, printcharfun
, 0);
1778 case Lisp_Misc_Boolfwd
:
1779 sprintf (buf
, "#<boolfwd to %s>",
1780 (*XBOOLFWD (obj
)->boolvar
? "t" : "nil"));
1781 strout (buf
, -1, -1, printcharfun
, 0);
1784 case Lisp_Misc_Objfwd
:
1785 strout ("#<objfwd to ", -1, -1, printcharfun
, 0);
1786 print_object (*XOBJFWD (obj
)->objvar
, printcharfun
, escapeflag
);
1790 case Lisp_Misc_Buffer_Objfwd
:
1791 strout ("#<buffer_objfwd to ", -1, -1, printcharfun
, 0);
1792 print_object (PER_BUFFER_VALUE (current_buffer
,
1793 XBUFFER_OBJFWD (obj
)->offset
),
1794 printcharfun
, escapeflag
);
1798 case Lisp_Misc_Kboard_Objfwd
:
1799 strout ("#<kboard_objfwd to ", -1, -1, printcharfun
, 0);
1800 print_object (*(Lisp_Object
*)((char *) current_kboard
1801 + XKBOARD_OBJFWD (obj
)->offset
),
1802 printcharfun
, escapeflag
);
1806 case Lisp_Misc_Buffer_Local_Value
:
1807 strout ("#<buffer_local_value ", -1, -1, printcharfun
, 0);
1808 goto do_buffer_local
;
1809 case Lisp_Misc_Some_Buffer_Local_Value
:
1810 strout ("#<some_buffer_local_value ", -1, -1, printcharfun
, 0);
1812 strout ("[realvalue] ", -1, -1, printcharfun
, 0);
1813 print_object (XBUFFER_LOCAL_VALUE (obj
)->realvalue
,
1814 printcharfun
, escapeflag
);
1815 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_buffer
)
1816 strout ("[local in buffer] ", -1, -1, printcharfun
, 0);
1818 strout ("[buffer] ", -1, -1, printcharfun
, 0);
1819 print_object (XBUFFER_LOCAL_VALUE (obj
)->buffer
,
1820 printcharfun
, escapeflag
);
1821 if (XBUFFER_LOCAL_VALUE (obj
)->check_frame
)
1823 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_frame
)
1824 strout ("[local in frame] ", -1, -1, printcharfun
, 0);
1826 strout ("[frame] ", -1, -1, printcharfun
, 0);
1827 print_object (XBUFFER_LOCAL_VALUE (obj
)->frame
,
1828 printcharfun
, escapeflag
);
1830 strout ("[alist-elt] ", -1, -1, printcharfun
, 0);
1831 print_object (XCAR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
1832 printcharfun
, escapeflag
);
1833 strout ("[default-value] ", -1, -1, printcharfun
, 0);
1834 print_object (XCDR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
1835 printcharfun
, escapeflag
);
1847 /* We're in trouble if this happens!
1848 Probably should just abort () */
1849 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
, 0);
1851 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
1852 else if (VECTORLIKEP (obj
))
1853 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
1855 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
1856 strout (buf
, -1, -1, printcharfun
, 0);
1857 strout (" Save your buffers immediately and please report this bug>",
1858 -1, -1, printcharfun
, 0);
1866 /* Print a description of INTERVAL using PRINTCHARFUN.
1867 This is part of printing a string that has text properties. */
1870 print_interval (interval
, printcharfun
)
1872 Lisp_Object printcharfun
;
1875 print_object (make_number (interval
->position
), printcharfun
, 1);
1877 print_object (make_number (interval
->position
+ LENGTH (interval
)),
1880 print_object (interval
->plist
, printcharfun
, 1);
1887 Qtemp_buffer_setup_hook
= intern ("temp-buffer-setup-hook");
1888 staticpro (&Qtemp_buffer_setup_hook
);
1890 DEFVAR_LISP ("standard-output", &Vstandard_output
,
1891 "Output stream `print' uses by default for outputting a character.\n\
1892 This may be any function of one argument.\n\
1893 It may also be a buffer (output is inserted before point)\n\
1894 or a marker (output is inserted and the marker is advanced)\n\
1895 or the symbol t (output appears in the echo area).");
1896 Vstandard_output
= Qt
;
1897 Qstandard_output
= intern ("standard-output");
1898 staticpro (&Qstandard_output
);
1900 DEFVAR_LISP ("float-output-format", &Vfloat_output_format
,
1901 "The format descriptor string used to print floats.\n\
1902 This is a %-spec like those accepted by `printf' in C,\n\
1903 but with some restrictions. It must start with the two characters `%.'.\n\
1904 After that comes an integer precision specification,\n\
1905 and then a letter which controls the format.\n\
1906 The letters allowed are `e', `f' and `g'.\n\
1907 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"\n\
1908 Use `f' for decimal point notation \"DIGITS.DIGITS\".\n\
1909 Use `g' to choose the shorter of those two formats for the number at hand.\n\
1910 The precision in any of these cases is the number of digits following\n\
1911 the decimal point. With `f', a precision of 0 means to omit the\n\
1912 decimal point. 0 is not allowed with `e' or `g'.\n\n\
1913 A value of nil means to use the shortest notation\n\
1914 that represents the number without losing information.");
1915 Vfloat_output_format
= Qnil
;
1916 Qfloat_output_format
= intern ("float-output-format");
1917 staticpro (&Qfloat_output_format
);
1919 DEFVAR_LISP ("print-length", &Vprint_length
,
1920 "Maximum length of list to print before abbreviating.\n\
1921 A value of nil means no limit.");
1922 Vprint_length
= Qnil
;
1924 DEFVAR_LISP ("print-level", &Vprint_level
,
1925 "Maximum depth of list nesting to print before abbreviating.\n\
1926 A value of nil means no limit.");
1927 Vprint_level
= Qnil
;
1929 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines
,
1930 "Non-nil means print newlines in strings as backslash-n.\n\
1931 Also print formfeeds as backslash-f.");
1932 print_escape_newlines
= 0;
1934 DEFVAR_BOOL ("print-escape-nonascii", &print_escape_nonascii
,
1935 "Non-nil means print unibyte non-ASCII chars in strings as \\OOO.\n\
1936 \(OOO is the octal representation of the character code.)\n\
1937 Only single-byte characters are affected, and only in `prin1'.");
1938 print_escape_nonascii
= 0;
1940 DEFVAR_BOOL ("print-escape-multibyte", &print_escape_multibyte
,
1941 "Non-nil means print multibyte characters in strings as \\xXXXX.\n\
1942 \(XXX is the hex representation of the character code.)\n\
1943 This affects only `prin1'.");
1944 print_escape_multibyte
= 0;
1946 DEFVAR_BOOL ("print-quoted", &print_quoted
,
1947 "Non-nil means print quoted forms with reader syntax.\n\
1948 I.e., (quote foo) prints as 'foo, (function foo) as #'foo, and, backquoted\n\
1949 forms print in the new syntax.");
1952 DEFVAR_LISP ("print-gensym", &Vprint_gensym
,
1953 "Non-nil means print uninterned symbols so they will read as uninterned.\n\
1954 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.\n\
1955 When the uninterned symbol appears within a recursive data structure\n\
1956 and the symbol appears more than once, in addition use the #N# and #N=\n\
1957 constructs as needed, so that multiple references to the same symbol are\n\
1958 shared once again when the text is read back.");
1959 Vprint_gensym
= Qnil
;
1961 DEFVAR_LISP ("print-circle", &Vprint_circle
,
1962 "*Non-nil means print recursive structures using #N= and #N# syntax.\n\
1963 If nil, printing proceeds recursively and may lead to\n\
1964 `max-lisp-eval-depth' being exceeded or an error may occur:\n\
1965 \"Apparently circular structure being printed.\" Also see\n\
1966 `print-length' and `print-level'.\n\
1967 If non-nil, shared substructures anywhere in the structure are printed\n\
1968 with `#N=' before the first occurrence (in the order of the print\n\
1969 representation) and `#N#' in place of each subsequent occurrence,\n\
1970 where N is a positive decimal integer.");
1971 Vprint_circle
= Qnil
;
1973 DEFVAR_LISP ("print-continuous-numbering", &Vprint_continuous_numbering
,
1974 "*Non-nil means keep numbering between several print functions.\n\
1975 See `print-gensym' nad `print-circle'. See also `print-number-table'.");
1976 Vprint_continuous_numbering
= Qnil
;
1978 DEFVAR_LISP ("print-number-table", &Vprint_number_table
,
1979 "A vector keeping the information of the current printed object.\n\
1980 This variable shouldn't be modified in Lisp level, but should be binded\n\
1981 with nil using let at the same position with `print-continuous-numbering',\n\
1982 so that the value of this variable can be freed after printing.");
1983 Vprint_number_table
= Qnil
;
1985 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
1986 staticpro (&Vprin1_to_string_buffer
);
1989 defsubr (&Sprin1_to_string
);
1990 defsubr (&Serror_message_string
);
1994 defsubr (&Swrite_char
);
1995 defsubr (&Sexternal_debugging_output
);
1997 Qexternal_debugging_output
= intern ("external-debugging-output");
1998 staticpro (&Qexternal_debugging_output
);
2000 Qprint_escape_newlines
= intern ("print-escape-newlines");
2001 staticpro (&Qprint_escape_newlines
);
2003 Qprint_escape_multibyte
= intern ("print-escape-multibyte");
2004 staticpro (&Qprint_escape_multibyte
);
2006 Qprint_escape_nonascii
= intern ("print-escape-nonascii");
2007 staticpro (&Qprint_escape_nonascii
);
2009 defsubr (&Swith_output_to_temp_buffer
);