1 /* Lisp object printing and output streams.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997,
3 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 Boston, MA 02110-1301, USA. */
33 #include "dispextern.h"
35 #include "intervals.h"
37 Lisp_Object Vstandard_output
, Qstandard_output
;
39 Lisp_Object Qtemp_buffer_setup_hook
;
41 /* These are used to print like we read. */
42 extern Lisp_Object Qbackquote
, Qcomma
, Qcomma_at
, Qcomma_dot
, Qfunction
;
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 /* Avoid actual stack overflow in print. */
95 /* Nonzero if inside outputting backquote in old style. */
96 int old_backquote_output
;
98 /* Detect most circularities to print finite output. */
99 #define PRINT_CIRCLE 200
100 Lisp_Object being_printed
[PRINT_CIRCLE
];
102 /* When printing into a buffer, first we put the text in this
103 block, then insert it all at once. */
106 /* Size allocated in print_buffer. */
107 int print_buffer_size
;
108 /* Chars stored in print_buffer. */
109 int print_buffer_pos
;
110 /* Bytes stored in print_buffer. */
111 int print_buffer_pos_byte
;
113 /* Maximum length of list to print in full; noninteger means
114 effectively infinity */
116 Lisp_Object Vprint_length
;
118 /* Maximum depth of list to print in full; noninteger means
119 effectively infinity. */
121 Lisp_Object Vprint_level
;
123 /* Nonzero means print newlines in strings as \n. */
125 int print_escape_newlines
;
127 /* Nonzero means to print single-byte non-ascii characters in strings as
130 int print_escape_nonascii
;
132 /* Nonzero means to print multibyte characters in strings as hex escapes. */
134 int print_escape_multibyte
;
136 Lisp_Object Qprint_escape_newlines
;
137 Lisp_Object Qprint_escape_multibyte
, Qprint_escape_nonascii
;
139 /* Nonzero means print (quote foo) forms as 'foo, etc. */
143 /* Non-nil means print #: before uninterned symbols. */
145 Lisp_Object Vprint_gensym
;
147 /* Non-nil means print recursive structures using #n= and #n# syntax. */
149 Lisp_Object Vprint_circle
;
151 /* Non-nil means keep continuous number for #n= and #n# syntax
152 between several print functions. */
154 Lisp_Object Vprint_continuous_numbering
;
156 /* Vprint_number_table is a vector like [OBJ1 STAT1 OBJ2 STAT2 ...],
157 where OBJn are objects going to be printed, and STATn are their status,
158 which may be different meanings during process. See the comments of
159 the functions print and print_preprocess for details.
160 print_number_index keeps the last position the next object should be added,
161 twice of which is the actual vector position in Vprint_number_table. */
162 int print_number_index
;
163 Lisp_Object Vprint_number_table
;
165 /* PRINT_NUMBER_OBJECT returns the I'th object in Vprint_number_table TABLE.
166 PRINT_NUMBER_STATUS returns the status of the I'th object in TABLE.
167 See the comment of the variable Vprint_number_table. */
168 #define PRINT_NUMBER_OBJECT(table,i) XVECTOR ((table))->contents[(i) * 2]
169 #define PRINT_NUMBER_STATUS(table,i) XVECTOR ((table))->contents[(i) * 2 + 1]
171 /* Nonzero means print newline to stdout before next minibuffer message.
172 Defined in xdisp.c */
174 extern int noninteractive_need_newline
;
176 extern int minibuffer_auto_raise
;
178 #ifdef MAX_PRINT_CHARS
179 static int print_chars
;
180 static int max_print
;
181 #endif /* MAX_PRINT_CHARS */
183 void print_interval ();
185 /* GDB resets this to zero on W32 to disable OutputDebugString calls. */
186 int print_output_debug_flag
= 1;
189 /* Low level output routines for characters and strings */
191 /* Lisp functions to do output using a stream
192 must have the stream in a variable called printcharfun
193 and must start with PRINTPREPARE, end with PRINTFINISH,
194 and use PRINTDECLARE to declare common variables.
195 Use PRINTCHAR to output one character,
196 or call strout to output a block of characters. */
198 #define PRINTDECLARE \
199 struct buffer *old = current_buffer; \
200 int old_point = -1, start_point = -1; \
201 int old_point_byte = -1, start_point_byte = -1; \
202 int specpdl_count = SPECPDL_INDEX (); \
203 int free_print_buffer = 0; \
204 int multibyte = !NILP (current_buffer->enable_multibyte_characters); \
207 #define PRINTPREPARE \
208 original = printcharfun; \
209 if (NILP (printcharfun)) printcharfun = Qt; \
210 if (BUFFERP (printcharfun)) \
212 if (XBUFFER (printcharfun) != current_buffer) \
213 Fset_buffer (printcharfun); \
214 printcharfun = Qnil; \
216 if (MARKERP (printcharfun)) \
218 EMACS_INT marker_pos; \
219 if (!(XMARKER (printcharfun)->buffer)) \
220 error ("Marker does not point anywhere"); \
221 if (XMARKER (printcharfun)->buffer != current_buffer) \
222 set_buffer_internal (XMARKER (printcharfun)->buffer); \
223 marker_pos = marker_position (printcharfun); \
224 if (marker_pos < BEGV || marker_pos > ZV) \
225 error ("Marker is outside the accessible part of the buffer"); \
227 old_point_byte = PT_BYTE; \
228 SET_PT_BOTH (marker_pos, \
229 marker_byte_position (printcharfun)); \
231 start_point_byte = PT_BYTE; \
232 printcharfun = Qnil; \
234 if (NILP (printcharfun)) \
236 Lisp_Object string; \
237 if (NILP (current_buffer->enable_multibyte_characters) \
238 && ! print_escape_multibyte) \
239 specbind (Qprint_escape_multibyte, Qt); \
240 if (! NILP (current_buffer->enable_multibyte_characters) \
241 && ! print_escape_nonascii) \
242 specbind (Qprint_escape_nonascii, Qt); \
243 if (print_buffer != 0) \
245 string = make_string_from_bytes (print_buffer, \
247 print_buffer_pos_byte); \
248 record_unwind_protect (print_unwind, string); \
252 print_buffer_size = 1000; \
253 print_buffer = (char *) xmalloc (print_buffer_size); \
254 free_print_buffer = 1; \
256 print_buffer_pos = 0; \
257 print_buffer_pos_byte = 0; \
259 if (EQ (printcharfun, Qt) && ! noninteractive) \
260 setup_echo_area_for_printing (multibyte);
262 #define PRINTFINISH \
263 if (NILP (printcharfun)) \
265 if (print_buffer_pos != print_buffer_pos_byte \
266 && NILP (current_buffer->enable_multibyte_characters)) \
268 unsigned char *temp \
269 = (unsigned char *) alloca (print_buffer_pos + 1); \
270 copy_text (print_buffer, temp, print_buffer_pos_byte, \
272 insert_1_both (temp, print_buffer_pos, \
273 print_buffer_pos, 0, 1, 0); \
276 insert_1_both (print_buffer, print_buffer_pos, \
277 print_buffer_pos_byte, 0, 1, 0); \
279 if (free_print_buffer) \
281 xfree (print_buffer); \
284 unbind_to (specpdl_count, Qnil); \
285 if (MARKERP (original)) \
286 set_marker_both (original, Qnil, PT, PT_BYTE); \
287 if (old_point >= 0) \
288 SET_PT_BOTH (old_point + (old_point >= start_point \
289 ? PT - start_point : 0), \
290 old_point_byte + (old_point_byte >= start_point_byte \
291 ? PT_BYTE - start_point_byte : 0)); \
292 if (old != current_buffer) \
293 set_buffer_internal (old);
295 #define PRINTCHAR(ch) printchar (ch, printcharfun)
297 /* This is used to restore the saved contents of print_buffer
298 when there is a recursive call to print. */
301 print_unwind (saved_text
)
302 Lisp_Object saved_text
;
304 bcopy (SDATA (saved_text
), print_buffer
, SCHARS (saved_text
));
309 /* Print character CH using method FUN. FUN nil means print to
310 print_buffer. FUN t means print to echo area or stdout if
311 non-interactive. If FUN is neither nil nor t, call FUN with CH as
319 #ifdef MAX_PRINT_CHARS
322 #endif /* MAX_PRINT_CHARS */
324 if (!NILP (fun
) && !EQ (fun
, Qt
))
325 call1 (fun
, make_number (ch
));
328 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
329 int len
= CHAR_STRING (ch
, str
);
335 if (print_buffer_pos_byte
+ len
>= print_buffer_size
)
336 print_buffer
= (char *) xrealloc (print_buffer
,
337 print_buffer_size
*= 2);
338 bcopy (str
, print_buffer
+ print_buffer_pos_byte
, len
);
339 print_buffer_pos
+= 1;
340 print_buffer_pos_byte
+= len
;
342 else if (noninteractive
)
344 fwrite (str
, 1, len
, stdout
);
345 noninteractive_need_newline
= 1;
350 = !NILP (current_buffer
->enable_multibyte_characters
);
352 setup_echo_area_for_printing (multibyte_p
);
354 message_dolog (str
, len
, 0, multibyte_p
);
360 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
361 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
362 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
363 print_buffer. PRINTCHARFUN t means output to the echo area or to
364 stdout if non-interactive. If neither nil nor t, call Lisp
365 function PRINTCHARFUN for each character printed. MULTIBYTE
366 non-zero means PTR contains multibyte characters. */
369 strout (ptr
, size
, size_byte
, printcharfun
, multibyte
)
372 Lisp_Object printcharfun
;
376 size_byte
= size
= strlen (ptr
);
378 if (NILP (printcharfun
))
380 if (print_buffer_pos_byte
+ size_byte
> print_buffer_size
)
382 print_buffer_size
= print_buffer_size
* 2 + size_byte
;
383 print_buffer
= (char *) xrealloc (print_buffer
,
386 bcopy (ptr
, print_buffer
+ print_buffer_pos_byte
, size_byte
);
387 print_buffer_pos
+= size
;
388 print_buffer_pos_byte
+= size_byte
;
390 #ifdef MAX_PRINT_CHARS
393 #endif /* MAX_PRINT_CHARS */
395 else if (noninteractive
&& EQ (printcharfun
, Qt
))
397 fwrite (ptr
, 1, size_byte
, stdout
);
398 noninteractive_need_newline
= 1;
400 else if (EQ (printcharfun
, Qt
))
402 /* Output to echo area. We're trying to avoid a little overhead
403 here, that's the reason we don't call printchar to do the
407 = !NILP (current_buffer
->enable_multibyte_characters
);
409 setup_echo_area_for_printing (multibyte_p
);
410 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
412 if (size
== size_byte
)
414 for (i
= 0; i
< size
; ++i
)
415 insert_char ((unsigned char )*ptr
++);
420 for (i
= 0; i
< size_byte
; i
+= len
)
422 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size_byte
- i
, len
);
427 #ifdef MAX_PRINT_CHARS
430 #endif /* MAX_PRINT_CHARS */
434 /* PRINTCHARFUN is a Lisp function. */
437 if (size
== size_byte
)
439 while (i
< size_byte
)
447 while (i
< size_byte
)
449 /* Here, we must convert each multi-byte form to the
450 corresponding character code before handing it to
453 int ch
= STRING_CHAR_AND_LENGTH (ptr
+ i
, size_byte
- i
, len
);
461 /* Print the contents of a string STRING using PRINTCHARFUN.
462 It isn't safe to use strout in many cases,
463 because printing one char can relocate. */
466 print_string (string
, printcharfun
)
468 Lisp_Object printcharfun
;
470 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
474 if (STRING_MULTIBYTE (string
))
475 chars
= SCHARS (string
);
476 else if (EQ (printcharfun
, Qt
)
477 ? ! NILP (buffer_defaults
.enable_multibyte_characters
)
478 : ! NILP (current_buffer
->enable_multibyte_characters
))
480 /* If unibyte string STRING contains 8-bit codes, we must
481 convert STRING to a multibyte string containing the same
486 chars
= SBYTES (string
);
487 bytes
= parse_str_to_multibyte (SDATA (string
), chars
);
490 newstr
= make_uninit_multibyte_string (chars
, bytes
);
491 bcopy (SDATA (string
), SDATA (newstr
), chars
);
492 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
497 chars
= SBYTES (string
);
499 /* strout is safe for output to a frame (echo area) or to print_buffer. */
500 strout (SDATA (string
),
501 chars
, SBYTES (string
),
502 printcharfun
, STRING_MULTIBYTE (string
));
506 /* Otherwise, string may be relocated by printing one char.
507 So re-fetch the string address for each character. */
509 int size
= SCHARS (string
);
510 int size_byte
= SBYTES (string
);
513 if (size
== size_byte
)
514 for (i
= 0; i
< size
; i
++)
515 PRINTCHAR (SREF (string
, i
));
517 for (i
= 0; i
< size_byte
; )
519 /* Here, we must convert each multi-byte form to the
520 corresponding character code before handing it to PRINTCHAR. */
522 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
,
524 if (!CHAR_VALID_P (ch
, 0))
526 ch
= SREF (string
, i
);
536 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
537 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
538 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
539 (character
, printcharfun
)
540 Lisp_Object character
, printcharfun
;
544 if (NILP (printcharfun
))
545 printcharfun
= Vstandard_output
;
546 CHECK_NUMBER (character
);
548 PRINTCHAR (XINT (character
));
553 /* Used from outside of print.c to print a block of SIZE
554 single-byte chars at DATA on the default output stream.
555 Do not use this on the contents of a Lisp string. */
558 write_string (data
, size
)
563 Lisp_Object printcharfun
;
565 printcharfun
= Vstandard_output
;
568 strout (data
, size
, size
, printcharfun
, 0);
572 /* Used from outside of print.c to print a block of SIZE
573 single-byte chars at DATA on a specified stream PRINTCHARFUN.
574 Do not use this on the contents of a Lisp string. */
577 write_string_1 (data
, size
, printcharfun
)
580 Lisp_Object printcharfun
;
585 strout (data
, size
, size
, printcharfun
, 0);
591 temp_output_buffer_setup (bufname
)
594 int count
= SPECPDL_INDEX ();
595 register struct buffer
*old
= current_buffer
;
596 register Lisp_Object buf
;
598 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
600 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
602 Fkill_all_local_variables ();
603 delete_all_overlays (current_buffer
);
604 current_buffer
->directory
= old
->directory
;
605 current_buffer
->read_only
= Qnil
;
606 current_buffer
->filename
= Qnil
;
607 current_buffer
->undo_list
= Qt
;
608 eassert (current_buffer
->overlays_before
== NULL
);
609 eassert (current_buffer
->overlays_after
== NULL
);
610 current_buffer
->enable_multibyte_characters
611 = buffer_defaults
.enable_multibyte_characters
;
612 specbind (Qinhibit_read_only
, Qt
);
613 specbind (Qinhibit_modification_hooks
, Qt
);
615 XSETBUFFER (buf
, current_buffer
);
617 Frun_hooks (1, &Qtemp_buffer_setup_hook
);
619 unbind_to (count
, Qnil
);
621 specbind (Qstandard_output
, buf
);
625 internal_with_output_to_temp_buffer (bufname
, function
, args
)
627 Lisp_Object (*function
) P_ ((Lisp_Object
));
630 int count
= SPECPDL_INDEX ();
631 Lisp_Object buf
, val
;
635 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
636 temp_output_buffer_setup (bufname
);
637 buf
= Vstandard_output
;
640 val
= (*function
) (args
);
643 temp_output_buffer_show (buf
);
646 return unbind_to (count
, val
);
649 DEFUN ("with-output-to-temp-buffer",
650 Fwith_output_to_temp_buffer
, Swith_output_to_temp_buffer
,
652 doc
: /* Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
653 The buffer is cleared out initially, and marked as unmodified when done.
654 All output done by BODY is inserted in that buffer by default.
655 The buffer is displayed in another window, but not selected.
656 The value of the last form in BODY is returned.
657 If BODY does not finish normally, the buffer BUFNAME is not displayed.
659 The hook `temp-buffer-setup-hook' is run before BODY,
660 with the buffer BUFNAME temporarily current.
661 The hook `temp-buffer-show-hook' is run after the buffer is displayed,
662 with the buffer temporarily current, and the window that was used
663 to display it temporarily selected.
665 If variable `temp-buffer-show-function' is non-nil, call it at the end
666 to get the buffer displayed instead of just displaying the non-selected
667 buffer and calling the hook. It gets one argument, the buffer to display.
669 usage: (with-output-to-temp-buffer BUFNAME BODY ...) */)
675 int count
= SPECPDL_INDEX ();
676 Lisp_Object buf
, val
;
679 name
= Feval (Fcar (args
));
681 temp_output_buffer_setup (SDATA (name
));
682 buf
= Vstandard_output
;
685 val
= Fprogn (XCDR (args
));
688 temp_output_buffer_show (buf
);
691 return unbind_to (count
, val
);
695 static void print ();
696 static void print_preprocess ();
697 static void print_preprocess_string ();
698 static void print_object ();
700 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
701 doc
: /* Output a newline to stream PRINTCHARFUN.
702 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
704 Lisp_Object printcharfun
;
708 if (NILP (printcharfun
))
709 printcharfun
= Vstandard_output
;
716 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
717 doc
: /* Output the printed representation of OBJECT, any Lisp object.
718 Quoting characters are printed when needed to make output that `read'
719 can handle, whenever this is possible. For complex objects, the behavior
720 is controlled by `print-level' and `print-length', which see.
722 OBJECT is any of the Lisp data types: a number, a string, a symbol,
723 a list, a buffer, a window, a frame, etc.
725 A printed representation of an object is text which describes that object.
727 Optional argument PRINTCHARFUN is the output stream, which can be one
730 - a buffer, in which case output is inserted into that buffer at point;
731 - a marker, in which case output is inserted at marker's position;
732 - a function, in which case that function is called once for each
733 character of OBJECT's printed representation;
734 - a symbol, in which case that symbol's function definition is called; or
735 - t, in which case the output is displayed in the echo area.
737 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
739 (object
, printcharfun
)
740 Lisp_Object object
, printcharfun
;
744 #ifdef MAX_PRINT_CHARS
746 #endif /* MAX_PRINT_CHARS */
747 if (NILP (printcharfun
))
748 printcharfun
= Vstandard_output
;
750 print (object
, printcharfun
, 1);
755 /* a buffer which is used to hold output being built by prin1-to-string */
756 Lisp_Object Vprin1_to_string_buffer
;
758 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
759 doc
: /* Return a string containing the printed representation of OBJECT.
760 OBJECT can be any Lisp object. This function outputs quoting characters
761 when necessary to make output that `read' can handle, whenever possible,
762 unless the optional second argument NOESCAPE is non-nil.
764 OBJECT is any of the Lisp data types: a number, a string, a symbol,
765 a list, a buffer, a window, a frame, etc.
767 A printed representation of an object is text which describes that object. */)
769 Lisp_Object object
, noescape
;
771 Lisp_Object printcharfun
;
772 /* struct gcpro gcpro1, gcpro2; */
773 Lisp_Object save_deactivate_mark
;
774 int count
= specpdl_ptr
- specpdl
;
775 struct buffer
*previous
;
777 specbind (Qinhibit_modification_hooks
, Qt
);
782 /* Save and restore this--we are altering a buffer
783 but we don't want to deactivate the mark just for that.
784 No need for specbind, since errors deactivate the mark. */
785 save_deactivate_mark
= Vdeactivate_mark
;
786 /* GCPRO2 (object, save_deactivate_mark); */
789 printcharfun
= Vprin1_to_string_buffer
;
791 print (object
, printcharfun
, NILP (noescape
));
792 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
796 previous
= current_buffer
;
797 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
798 object
= Fbuffer_string ();
799 if (SBYTES (object
) == SCHARS (object
))
800 STRING_SET_UNIBYTE (object
);
802 /* Note that this won't make prepare_to_modify_buffer call
803 ask-user-about-supersession-threat because this buffer
804 does not visit a file. */
806 set_buffer_internal (previous
);
808 Vdeactivate_mark
= save_deactivate_mark
;
812 return unbind_to (count
, object
);
815 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
816 doc
: /* Output the printed representation of OBJECT, any Lisp object.
817 No quoting characters are used; no delimiters are printed around
818 the contents of strings.
820 OBJECT is any of the Lisp data types: a number, a string, a symbol,
821 a list, a buffer, a window, a frame, etc.
823 A printed representation of an object is text which describes that object.
825 Optional argument PRINTCHARFUN is the output stream, which can be one
828 - a buffer, in which case output is inserted into that buffer at point;
829 - a marker, in which case output is inserted at marker's position;
830 - a function, in which case that function is called once for each
831 character of OBJECT's printed representation;
832 - a symbol, in which case that symbol's function definition is called; or
833 - t, in which case the output is displayed in the echo area.
835 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
837 (object
, printcharfun
)
838 Lisp_Object object
, printcharfun
;
842 if (NILP (printcharfun
))
843 printcharfun
= Vstandard_output
;
845 print (object
, printcharfun
, 0);
850 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
851 doc
: /* Output the printed representation of OBJECT, with newlines around it.
852 Quoting characters are printed when needed to make output that `read'
853 can handle, whenever this is possible. For complex objects, the behavior
854 is controlled by `print-level' and `print-length', which see.
856 OBJECT is any of the Lisp data types: a number, a string, a symbol,
857 a list, a buffer, a window, a frame, etc.
859 A printed representation of an object is text which describes that object.
861 Optional argument PRINTCHARFUN is the output stream, which can be one
864 - a buffer, in which case output is inserted into that buffer at point;
865 - a marker, in which case output is inserted at marker's position;
866 - a function, in which case that function is called once for each
867 character of OBJECT's printed representation;
868 - a symbol, in which case that symbol's function definition is called; or
869 - t, in which case the output is displayed in the echo area.
871 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
873 (object
, printcharfun
)
874 Lisp_Object object
, printcharfun
;
879 #ifdef MAX_PRINT_CHARS
881 max_print
= MAX_PRINT_CHARS
;
882 #endif /* MAX_PRINT_CHARS */
883 if (NILP (printcharfun
))
884 printcharfun
= Vstandard_output
;
888 print (object
, printcharfun
, 1);
891 #ifdef MAX_PRINT_CHARS
894 #endif /* MAX_PRINT_CHARS */
899 /* The subroutine object for external-debugging-output is kept here
900 for the convenience of the debugger. */
901 Lisp_Object Qexternal_debugging_output
;
903 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
904 doc
: /* Write CHARACTER to stderr.
905 You can call print while debugging emacs, and pass it this function
906 to make it write to the debugging output. */)
908 Lisp_Object character
;
910 CHECK_NUMBER (character
);
911 putc (XINT (character
), stderr
);
914 /* Send the output to a debugger (nothing happens if there isn't one). */
915 if (print_output_debug_flag
)
917 char buf
[2] = {(char) XINT (character
), '\0'};
918 OutputDebugString (buf
);
926 #if defined(GNU_LINUX)
928 /* This functionality is not vitally important in general, so we rely on
929 non-portable ability to use stderr as lvalue. */
931 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
933 FILE *initial_stderr_stream
= NULL
;
935 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
937 "FDebug output file: \nP",
938 doc
: /* Redirect debugging output (stderr stream) to file FILE.
939 If FILE is nil, reset target to the initial stderr stream.
940 Optional arg APPEND non-nil (interactively, with prefix arg) means
941 append to existing target file. */)
943 Lisp_Object file
, append
;
945 if (initial_stderr_stream
!= NULL
)
947 stderr
= initial_stderr_stream
;
948 initial_stderr_stream
= NULL
;
952 file
= Fexpand_file_name (file
, Qnil
);
953 initial_stderr_stream
= stderr
;
954 stderr
= fopen(SDATA (file
), NILP (append
) ? "w" : "a");
957 stderr
= initial_stderr_stream
;
958 initial_stderr_stream
= NULL
;
959 report_file_error ("Cannot open debugging output stream",
965 #endif /* GNU_LINUX */
968 /* This is the interface for debugging printing. */
974 Fprin1 (arg
, Qexternal_debugging_output
);
975 fprintf (stderr
, "\r\n");
979 safe_debug_print (arg
)
982 int valid
= valid_lisp_object_p (arg
);
987 fprintf (stderr
, "#<%s_LISP_OBJECT 0x%08lx>\r\n",
988 !valid
? "INVALID" : "SOME",
992 (unsigned long) arg
.i
998 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
1000 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
1001 See Info anchor `(elisp)Definition of signal' for some details on how this
1002 error message is constructed. */)
1006 struct buffer
*old
= current_buffer
;
1008 struct gcpro gcpro1
;
1010 /* If OBJ is (error STRING), just return STRING.
1011 That is not only faster, it also avoids the need to allocate
1012 space here when the error is due to memory full. */
1013 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
1014 && CONSP (XCDR (obj
))
1015 && STRINGP (XCAR (XCDR (obj
)))
1016 && NILP (XCDR (XCDR (obj
))))
1017 return XCAR (XCDR (obj
));
1019 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
1021 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
1022 value
= Fbuffer_string ();
1026 set_buffer_internal (old
);
1032 /* Print an error message for the error DATA onto Lisp output stream
1033 STREAM (suitable for the print functions). */
1036 print_error_message (data
, stream
, context
, caller
)
1037 Lisp_Object data
, stream
;
1041 Lisp_Object errname
, errmsg
, file_error
, tail
;
1042 struct gcpro gcpro1
;
1046 write_string_1 (context
, -1, stream
);
1048 /* If we know from where the error was signaled, show it in
1050 if (!NILP (caller
) && SYMBOLP (caller
))
1052 Lisp_Object cname
= SYMBOL_NAME (caller
);
1053 char *name
= alloca (SBYTES (cname
));
1054 bcopy (SDATA (cname
), name
, SBYTES (cname
));
1055 message_dolog (name
, SBYTES (cname
), 0, 0);
1056 message_dolog (": ", 2, 0, 0);
1059 errname
= Fcar (data
);
1061 if (EQ (errname
, Qerror
))
1066 errmsg
= Fcar (data
);
1071 Lisp_Object error_conditions
;
1072 errmsg
= Fget (errname
, Qerror_message
);
1073 error_conditions
= Fget (errname
, Qerror_conditions
);
1074 file_error
= Fmemq (Qfile_error
, error_conditions
);
1077 /* Print an error message including the data items. */
1079 tail
= Fcdr_safe (data
);
1082 /* For file-error, make error message by concatenating
1083 all the data items. They are all strings. */
1084 if (!NILP (file_error
) && CONSP (tail
))
1085 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
1087 if (STRINGP (errmsg
))
1088 Fprinc (errmsg
, stream
);
1090 write_string_1 ("peculiar error", -1, stream
);
1092 for (i
= 0; CONSP (tail
); tail
= XCDR (tail
), i
++)
1096 write_string_1 (i
? ", " : ": ", 2, stream
);
1098 if (!NILP (file_error
) || EQ (errname
, Qend_of_file
))
1099 Fprinc (obj
, stream
);
1101 Fprin1 (obj
, stream
);
1110 * The buffer should be at least as large as the max string size of the
1111 * largest float, printed in the biggest notation. This is undoubtedly
1112 * 20d float_output_format, with the negative of the C-constant "HUGE"
1115 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
1117 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
1118 * case of -1e307 in 20d float_output_format. What is one to do (short of
1119 * re-writing _doprnt to be more sane)?
1124 float_to_string (buf
, data
)
1131 /* Check for plus infinity in a way that won't lose
1132 if there is no plus infinity. */
1133 if (data
== data
/ 2 && data
> 1.0)
1135 strcpy (buf
, "1.0e+INF");
1138 /* Likewise for minus infinity. */
1139 if (data
== data
/ 2 && data
< -1.0)
1141 strcpy (buf
, "-1.0e+INF");
1144 /* Check for NaN in a way that won't fail if there are no NaNs. */
1145 if (! (data
* 0.0 >= 0.0))
1147 /* Prepend "-" if the NaN's sign bit is negative.
1148 The sign bit of a double is the bit that is 1 in -0.0. */
1150 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
1152 u_minus_zero
.d
= - 0.0;
1153 for (i
= 0; i
< sizeof (double); i
++)
1154 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
1160 strcpy (buf
, "0.0e+NaN");
1164 if (NILP (Vfloat_output_format
)
1165 || !STRINGP (Vfloat_output_format
))
1168 /* Generate the fewest number of digits that represent the
1169 floating point value without losing information.
1170 The following method is simple but a bit slow.
1171 For ideas about speeding things up, please see:
1173 Guy L Steele Jr & Jon L White, How to print floating-point numbers
1174 accurately. SIGPLAN notices 25, 6 (June 1990), 112-126.
1176 Robert G Burger & R Kent Dybvig, Printing floating point numbers
1177 quickly and accurately, SIGPLAN notices 31, 5 (May 1996), 108-116. */
1179 width
= fabs (data
) < DBL_MIN
? 1 : DBL_DIG
;
1181 sprintf (buf
, "%.*g", width
, data
);
1182 while (width
++ < DOUBLE_DIGITS_BOUND
&& atof (buf
) != data
);
1184 else /* oink oink */
1186 /* Check that the spec we have is fully valid.
1187 This means not only valid for printf,
1188 but meant for floats, and reasonable. */
1189 cp
= SDATA (Vfloat_output_format
);
1198 /* Check the width specification. */
1200 if ('0' <= *cp
&& *cp
<= '9')
1204 width
= (width
* 10) + (*cp
++ - '0');
1205 while (*cp
>= '0' && *cp
<= '9');
1207 /* A precision of zero is valid only for %f. */
1209 || (width
== 0 && *cp
!= 'f'))
1213 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1219 sprintf (buf
, SDATA (Vfloat_output_format
), data
);
1222 /* Make sure there is a decimal point with digit after, or an
1223 exponent, so that the value is readable as a float. But don't do
1224 this with "%.0f"; it's valid for that not to produce a decimal
1225 point. Note that width can be 0 only for %.0f. */
1228 for (cp
= buf
; *cp
; cp
++)
1229 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1232 if (*cp
== '.' && cp
[1] == 0)
1249 print (obj
, printcharfun
, escapeflag
)
1251 register Lisp_Object printcharfun
;
1254 old_backquote_output
= 0;
1256 /* Reset print_number_index and Vprint_number_table only when
1257 the variable Vprint_continuous_numbering is nil. Otherwise,
1258 the values of these variables will be kept between several
1260 if (NILP (Vprint_continuous_numbering
))
1262 print_number_index
= 0;
1263 Vprint_number_table
= Qnil
;
1266 /* Construct Vprint_number_table for print-gensym and print-circle. */
1267 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1269 int i
, start
, index
;
1270 start
= index
= print_number_index
;
1271 /* Construct Vprint_number_table.
1272 This increments print_number_index for the objects added. */
1274 print_preprocess (obj
);
1276 /* Remove unnecessary objects, which appear only once in OBJ;
1277 that is, whose status is Qnil. Compactify the necessary objects. */
1278 for (i
= start
; i
< print_number_index
; i
++)
1279 if (!NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1281 PRINT_NUMBER_OBJECT (Vprint_number_table
, index
)
1282 = PRINT_NUMBER_OBJECT (Vprint_number_table
, i
);
1286 /* Clear out objects outside the active part of the table. */
1287 for (i
= index
; i
< print_number_index
; i
++)
1288 PRINT_NUMBER_OBJECT (Vprint_number_table
, i
) = Qnil
;
1290 /* Reset the status field for the next print step. Now this
1291 field means whether the object has already been printed. */
1292 for (i
= start
; i
< print_number_index
; i
++)
1293 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qnil
;
1295 print_number_index
= index
;
1299 print_object (obj
, printcharfun
, escapeflag
);
1302 /* Construct Vprint_number_table according to the structure of OBJ.
1303 OBJ itself and all its elements will be added to Vprint_number_table
1304 recursively if it is a list, vector, compiled function, char-table,
1305 string (its text properties will be traced), or a symbol that has
1306 no obarray (this is for the print-gensym feature).
1307 The status fields of Vprint_number_table mean whether each object appears
1308 more than once in OBJ: Qnil at the first time, and Qt after that . */
1310 print_preprocess (obj
)
1316 Lisp_Object halftail
;
1318 /* Give up if we go so deep that print_object will get an error. */
1319 /* See similar code in print_object. */
1320 if (print_depth
>= PRINT_CIRCLE
)
1321 error ("Apparently circular structure being printed");
1323 /* Avoid infinite recursion for circular nested structure
1324 in the case where Vprint_circle is nil. */
1325 if (NILP (Vprint_circle
))
1327 for (i
= 0; i
< print_depth
; i
++)
1328 if (EQ (obj
, being_printed
[i
]))
1330 being_printed
[print_depth
] = obj
;
1337 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1338 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
)
1339 || (! NILP (Vprint_gensym
)
1341 && !SYMBOL_INTERNED_P (obj
)))
1343 /* In case print-circle is nil and print-gensym is t,
1344 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1345 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1347 for (i
= 0; i
< print_number_index
; i
++)
1348 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
), obj
))
1350 /* OBJ appears more than once. Let's remember that. */
1351 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1356 /* OBJ is not yet recorded. Let's add to the table. */
1357 if (print_number_index
== 0)
1359 /* Initialize the table. */
1360 Vprint_number_table
= Fmake_vector (make_number (40), Qnil
);
1362 else if (XVECTOR (Vprint_number_table
)->size
== print_number_index
* 2)
1364 /* Reallocate the table. */
1365 int i
= print_number_index
* 4;
1366 Lisp_Object old_table
= Vprint_number_table
;
1367 Vprint_number_table
= Fmake_vector (make_number (i
), Qnil
);
1368 for (i
= 0; i
< print_number_index
; i
++)
1370 PRINT_NUMBER_OBJECT (Vprint_number_table
, i
)
1371 = PRINT_NUMBER_OBJECT (old_table
, i
);
1372 PRINT_NUMBER_STATUS (Vprint_number_table
, i
)
1373 = PRINT_NUMBER_STATUS (old_table
, i
);
1376 PRINT_NUMBER_OBJECT (Vprint_number_table
, print_number_index
) = obj
;
1377 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1378 always print the gensym with a number. This is a special for
1379 the lisp function byte-compile-output-docform. */
1380 if (!NILP (Vprint_continuous_numbering
)
1382 && !SYMBOL_INTERNED_P (obj
))
1383 PRINT_NUMBER_STATUS (Vprint_number_table
, print_number_index
) = Qt
;
1384 print_number_index
++;
1387 switch (XGCTYPE (obj
))
1390 /* A string may have text properties, which can be circular. */
1391 traverse_intervals_noorder (STRING_INTERVALS (obj
),
1392 print_preprocess_string
, Qnil
);
1396 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1397 just as in print_object. */
1398 if (loop_count
&& EQ (obj
, halftail
))
1400 print_preprocess (XCAR (obj
));
1403 if (!(loop_count
& 1))
1404 halftail
= XCDR (halftail
);
1407 case Lisp_Vectorlike
:
1408 size
= XVECTOR (obj
)->size
;
1409 if (size
& PSEUDOVECTOR_FLAG
)
1410 size
&= PSEUDOVECTOR_SIZE_MASK
;
1411 for (i
= 0; i
< size
; i
++)
1412 print_preprocess (XVECTOR (obj
)->contents
[i
]);
1423 print_preprocess_string (interval
, arg
)
1427 print_preprocess (interval
->plist
);
1431 print_object (obj
, printcharfun
, escapeflag
)
1433 register Lisp_Object printcharfun
;
1440 /* Detect circularities and truncate them. */
1441 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1442 || COMPILEDP (obj
) || CHAR_TABLE_P (obj
)
1443 || (! NILP (Vprint_gensym
)
1445 && !SYMBOL_INTERNED_P (obj
)))
1447 if (NILP (Vprint_circle
) && NILP (Vprint_gensym
))
1449 /* Simple but incomplete way. */
1451 for (i
= 0; i
< print_depth
; i
++)
1452 if (EQ (obj
, being_printed
[i
]))
1454 sprintf (buf
, "#%d", i
);
1455 strout (buf
, -1, -1, printcharfun
, 0);
1458 being_printed
[print_depth
] = obj
;
1462 /* With the print-circle feature. */
1464 for (i
= 0; i
< print_number_index
; i
++)
1465 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
), obj
))
1467 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1469 /* Add a prefix #n= if OBJ has not yet been printed;
1470 that is, its status field is nil. */
1471 sprintf (buf
, "#%d=", i
+ 1);
1472 strout (buf
, -1, -1, printcharfun
, 0);
1473 /* OBJ is going to be printed. Set the status to t. */
1474 PRINT_NUMBER_STATUS (Vprint_number_table
, i
) = Qt
;
1479 /* Just print #n# if OBJ has already been printed. */
1480 sprintf (buf
, "#%d#", i
+ 1);
1481 strout (buf
, -1, -1, printcharfun
, 0);
1490 /* See similar code in print_preprocess. */
1491 if (print_depth
> PRINT_CIRCLE
)
1492 error ("Apparently circular structure being printed");
1493 #ifdef MAX_PRINT_CHARS
1494 if (max_print
&& print_chars
> max_print
)
1499 #endif /* MAX_PRINT_CHARS */
1501 switch (XGCTYPE (obj
))
1504 if (sizeof (int) == sizeof (EMACS_INT
))
1505 sprintf (buf
, "%d", XINT (obj
));
1506 else if (sizeof (long) == sizeof (EMACS_INT
))
1507 sprintf (buf
, "%ld", (long) XINT (obj
));
1510 strout (buf
, -1, -1, printcharfun
, 0);
1515 char pigbuf
[350]; /* see comments in float_to_string */
1517 float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1518 strout (pigbuf
, -1, -1, printcharfun
, 0);
1524 print_string (obj
, printcharfun
);
1527 register int i
, i_byte
;
1528 struct gcpro gcpro1
;
1531 /* 1 means we must ensure that the next character we output
1532 cannot be taken as part of a hex character escape. */
1533 int need_nonhex
= 0;
1534 int multibyte
= STRING_MULTIBYTE (obj
);
1538 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1546 size_byte
= SBYTES (obj
);
1548 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1550 /* Here, we must convert each multi-byte form to the
1551 corresponding character code before handing it to PRINTCHAR. */
1557 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
,
1558 size_byte
- i_byte
, len
);
1559 if (CHAR_VALID_P (c
, 0))
1569 if (c
== '\n' && print_escape_newlines
)
1574 else if (c
== '\f' && print_escape_newlines
)
1580 && ! ASCII_BYTE_P (c
)
1581 && (SINGLE_BYTE_CHAR_P (c
) || print_escape_multibyte
))
1583 /* When multibyte is disabled,
1584 print multibyte string chars using hex escapes.
1585 For a char code that could be in a unibyte string,
1586 when found in a multibyte string, always use a hex escape
1587 so it reads back as multibyte. */
1588 unsigned char outbuf
[50];
1589 sprintf (outbuf
, "\\x%x", c
);
1590 strout (outbuf
, -1, -1, printcharfun
, 0);
1593 else if (! multibyte
1594 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1595 && print_escape_nonascii
)
1597 /* When printing in a multibyte buffer
1598 or when explicitly requested,
1599 print single-byte non-ASCII string chars
1600 using octal escapes. */
1601 unsigned char outbuf
[5];
1602 sprintf (outbuf
, "\\%03o", c
);
1603 strout (outbuf
, -1, -1, printcharfun
, 0);
1607 /* If we just had a hex escape, and this character
1608 could be taken as part of it,
1609 output `\ ' to prevent that. */
1613 if ((c
>= 'a' && c
<= 'f')
1614 || (c
>= 'A' && c
<= 'F')
1615 || (c
>= '0' && c
<= '9'))
1616 strout ("\\ ", -1, -1, printcharfun
, 0);
1619 if (c
== '\"' || c
== '\\')
1626 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1628 traverse_intervals (STRING_INTERVALS (obj
),
1629 0, print_interval
, printcharfun
);
1639 register int confusing
;
1640 register unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1641 register unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1643 int i
, i_byte
, size_byte
;
1646 name
= SYMBOL_NAME (obj
);
1648 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1651 /* If symbol name begins with a digit, and ends with a digit,
1652 and contains nothing but digits and `e', it could be treated
1653 as a number. So set CONFUSING.
1655 Symbols that contain periods could also be taken as numbers,
1656 but periods are always escaped, so we don't have to worry
1658 else if (*p
>= '0' && *p
<= '9'
1659 && end
[-1] >= '0' && end
[-1] <= '9')
1661 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1662 /* Needed for \2e10. */
1665 confusing
= (end
== p
);
1670 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1676 size_byte
= SBYTES (name
);
1678 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1680 /* Here, we must convert each multi-byte form to the
1681 corresponding character code before handing it to PRINTCHAR. */
1682 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1687 if (c
== '\"' || c
== '\\' || c
== '\''
1688 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1689 || c
== ',' || c
=='.' || c
== '`'
1690 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1692 PRINTCHAR ('\\'), confusing
= 0;
1700 /* If deeper than spec'd depth, print placeholder. */
1701 if (INTEGERP (Vprint_level
)
1702 && print_depth
> XINT (Vprint_level
))
1703 strout ("...", -1, -1, printcharfun
, 0);
1704 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1705 && (EQ (XCAR (obj
), Qquote
)))
1708 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1710 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1711 && (EQ (XCAR (obj
), Qfunction
)))
1715 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1717 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1718 && ! old_backquote_output
1719 && ((EQ (XCAR (obj
), Qbackquote
)
1720 || EQ (XCAR (obj
), Qcomma
)
1721 || EQ (XCAR (obj
), Qcomma_at
)
1722 || EQ (XCAR (obj
), Qcomma_dot
))))
1724 print_object (XCAR (obj
), printcharfun
, 0);
1725 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1731 /* If the first element is a backquote form,
1732 print it old-style so it won't be misunderstood. */
1733 if (print_quoted
&& CONSP (XCAR (obj
))
1734 && CONSP (XCDR (XCAR (obj
)))
1735 && NILP (XCDR (XCDR (XCAR (obj
))))
1736 && EQ (XCAR (XCAR (obj
)), Qbackquote
))
1742 print_object (Qbackquote
, printcharfun
, 0);
1745 ++old_backquote_output
;
1746 print_object (XCAR (XCDR (tem
)), printcharfun
, 0);
1747 --old_backquote_output
;
1754 int print_length
, i
;
1755 Lisp_Object halftail
= obj
;
1757 /* Negative values of print-length are invalid in CL.
1758 Treat them like nil, as CMUCL does. */
1759 if (NATNUMP (Vprint_length
))
1760 print_length
= XFASTINT (Vprint_length
);
1767 /* Detect circular list. */
1768 if (NILP (Vprint_circle
))
1770 /* Simple but imcomplete way. */
1771 if (i
!= 0 && EQ (obj
, halftail
))
1773 sprintf (buf
, " . #%d", i
/ 2);
1774 strout (buf
, -1, -1, printcharfun
, 0);
1780 /* With the print-circle feature. */
1784 for (i
= 0; i
< print_number_index
; i
++)
1785 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table
, i
),
1788 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table
, i
)))
1790 strout (" . ", 3, 3, printcharfun
, 0);
1791 print_object (obj
, printcharfun
, escapeflag
);
1795 sprintf (buf
, " . #%d#", i
+ 1);
1796 strout (buf
, -1, -1, printcharfun
, 0);
1806 if (print_length
&& i
> print_length
)
1808 strout ("...", 3, 3, printcharfun
, 0);
1812 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1816 halftail
= XCDR (halftail
);
1820 /* OBJ non-nil here means it's the end of a dotted list. */
1823 strout (" . ", 3, 3, printcharfun
, 0);
1824 print_object (obj
, printcharfun
, escapeflag
);
1832 case Lisp_Vectorlike
:
1837 strout ("#<process ", -1, -1, printcharfun
, 0);
1838 print_string (XPROCESS (obj
)->name
, printcharfun
);
1842 print_string (XPROCESS (obj
)->name
, printcharfun
);
1844 else if (BOOL_VECTOR_P (obj
))
1847 register unsigned char c
;
1848 struct gcpro gcpro1
;
1850 = ((XBOOL_VECTOR (obj
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
1851 / BOOL_VECTOR_BITS_PER_CHAR
);
1857 sprintf (buf
, "%ld", (long) XBOOL_VECTOR (obj
)->size
);
1858 strout (buf
, -1, -1, printcharfun
, 0);
1861 /* Don't print more characters than the specified maximum.
1862 Negative values of print-length are invalid. Treat them
1863 like a print-length of nil. */
1864 if (NATNUMP (Vprint_length
)
1865 && XFASTINT (Vprint_length
) < size_in_chars
)
1866 size_in_chars
= XFASTINT (Vprint_length
);
1868 for (i
= 0; i
< size_in_chars
; i
++)
1871 c
= XBOOL_VECTOR (obj
)->data
[i
];
1872 if (c
== '\n' && print_escape_newlines
)
1877 else if (c
== '\f' && print_escape_newlines
)
1882 else if (c
> '\177')
1884 /* Use octal escapes to avoid encoding issues. */
1886 PRINTCHAR ('0' + ((c
>> 6) & 3));
1887 PRINTCHAR ('0' + ((c
>> 3) & 7));
1888 PRINTCHAR ('0' + (c
& 7));
1892 if (c
== '\"' || c
== '\\')
1901 else if (SUBRP (obj
))
1903 strout ("#<subr ", -1, -1, printcharfun
, 0);
1904 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
, 0);
1907 else if (WINDOWP (obj
))
1909 strout ("#<window ", -1, -1, printcharfun
, 0);
1910 sprintf (buf
, "%ld", (long) XFASTINT (XWINDOW (obj
)->sequence_number
));
1911 strout (buf
, -1, -1, printcharfun
, 0);
1912 if (!NILP (XWINDOW (obj
)->buffer
))
1914 strout (" on ", -1, -1, printcharfun
, 0);
1915 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1919 else if (HASH_TABLE_P (obj
))
1921 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1922 strout ("#<hash-table", -1, -1, printcharfun
, 0);
1923 if (SYMBOLP (h
->test
))
1927 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
, 0);
1929 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
, 0);
1931 sprintf (buf
, "%ld/%ld", (long) XFASTINT (h
->count
),
1932 (long) XVECTOR (h
->next
)->size
);
1933 strout (buf
, -1, -1, printcharfun
, 0);
1935 sprintf (buf
, " 0x%lx", (unsigned long) h
);
1936 strout (buf
, -1, -1, printcharfun
, 0);
1939 else if (BUFFERP (obj
))
1941 if (NILP (XBUFFER (obj
)->name
))
1942 strout ("#<killed buffer>", -1, -1, printcharfun
, 0);
1943 else if (escapeflag
)
1945 strout ("#<buffer ", -1, -1, printcharfun
, 0);
1946 print_string (XBUFFER (obj
)->name
, printcharfun
);
1950 print_string (XBUFFER (obj
)->name
, printcharfun
);
1952 else if (WINDOW_CONFIGURATIONP (obj
))
1954 strout ("#<window-configuration>", -1, -1, printcharfun
, 0);
1956 else if (FRAMEP (obj
))
1958 strout ((FRAME_LIVE_P (XFRAME (obj
))
1959 ? "#<frame " : "#<dead frame "),
1960 -1, -1, printcharfun
, 0);
1961 print_string (XFRAME (obj
)->name
, printcharfun
);
1962 sprintf (buf
, " 0x%lx", (unsigned long) (XFRAME (obj
)));
1963 strout (buf
, -1, -1, printcharfun
, 0);
1968 EMACS_INT size
= XVECTOR (obj
)->size
;
1969 if (COMPILEDP (obj
))
1972 size
&= PSEUDOVECTOR_SIZE_MASK
;
1974 if (CHAR_TABLE_P (obj
))
1976 /* We print a char-table as if it were a vector,
1977 lumping the parent and default slots in with the
1978 character slots. But we add #^ as a prefix. */
1981 if (SUB_CHAR_TABLE_P (obj
))
1983 size
&= PSEUDOVECTOR_SIZE_MASK
;
1985 if (size
& PSEUDOVECTOR_FLAG
)
1991 register Lisp_Object tem
;
1992 int real_size
= size
;
1994 /* Don't print more elements than the specified maximum. */
1995 if (NATNUMP (Vprint_length
)
1996 && XFASTINT (Vprint_length
) < size
)
1997 size
= XFASTINT (Vprint_length
);
1999 for (i
= 0; i
< size
; i
++)
2001 if (i
) PRINTCHAR (' ');
2002 tem
= XVECTOR (obj
)->contents
[i
];
2003 print_object (tem
, printcharfun
, escapeflag
);
2005 if (size
< real_size
)
2006 strout (" ...", 4, 4, printcharfun
, 0);
2013 switch (XMISCTYPE (obj
))
2015 case Lisp_Misc_Marker
:
2016 strout ("#<marker ", -1, -1, printcharfun
, 0);
2017 /* Do you think this is necessary? */
2018 if (XMARKER (obj
)->insertion_type
!= 0)
2019 strout ("(moves after insertion) ", -1, -1, printcharfun
, 0);
2020 if (!(XMARKER (obj
)->buffer
))
2021 strout ("in no buffer", -1, -1, printcharfun
, 0);
2024 sprintf (buf
, "at %d", marker_position (obj
));
2025 strout (buf
, -1, -1, printcharfun
, 0);
2026 strout (" in ", -1, -1, printcharfun
, 0);
2027 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
2032 case Lisp_Misc_Overlay
:
2033 strout ("#<overlay ", -1, -1, printcharfun
, 0);
2034 if (!(XMARKER (OVERLAY_START (obj
))->buffer
))
2035 strout ("in no buffer", -1, -1, printcharfun
, 0);
2038 sprintf (buf
, "from %d to %d in ",
2039 marker_position (OVERLAY_START (obj
)),
2040 marker_position (OVERLAY_END (obj
)));
2041 strout (buf
, -1, -1, printcharfun
, 0);
2042 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
2048 /* Remaining cases shouldn't happen in normal usage, but let's print
2049 them anyway for the benefit of the debugger. */
2050 case Lisp_Misc_Free
:
2051 strout ("#<misc free cell>", -1, -1, printcharfun
, 0);
2054 case Lisp_Misc_Intfwd
:
2055 sprintf (buf
, "#<intfwd to %ld>", (long) *XINTFWD (obj
)->intvar
);
2056 strout (buf
, -1, -1, printcharfun
, 0);
2059 case Lisp_Misc_Boolfwd
:
2060 sprintf (buf
, "#<boolfwd to %s>",
2061 (*XBOOLFWD (obj
)->boolvar
? "t" : "nil"));
2062 strout (buf
, -1, -1, printcharfun
, 0);
2065 case Lisp_Misc_Objfwd
:
2066 strout ("#<objfwd to ", -1, -1, printcharfun
, 0);
2067 print_object (*XOBJFWD (obj
)->objvar
, printcharfun
, escapeflag
);
2071 case Lisp_Misc_Buffer_Objfwd
:
2072 strout ("#<buffer_objfwd to ", -1, -1, printcharfun
, 0);
2073 print_object (PER_BUFFER_VALUE (current_buffer
,
2074 XBUFFER_OBJFWD (obj
)->offset
),
2075 printcharfun
, escapeflag
);
2079 case Lisp_Misc_Kboard_Objfwd
:
2080 strout ("#<kboard_objfwd to ", -1, -1, printcharfun
, 0);
2081 print_object (*(Lisp_Object
*)((char *) current_kboard
2082 + XKBOARD_OBJFWD (obj
)->offset
),
2083 printcharfun
, escapeflag
);
2087 case Lisp_Misc_Buffer_Local_Value
:
2088 strout ("#<buffer_local_value ", -1, -1, printcharfun
, 0);
2089 goto do_buffer_local
;
2090 case Lisp_Misc_Some_Buffer_Local_Value
:
2091 strout ("#<some_buffer_local_value ", -1, -1, printcharfun
, 0);
2093 strout ("[realvalue] ", -1, -1, printcharfun
, 0);
2094 print_object (XBUFFER_LOCAL_VALUE (obj
)->realvalue
,
2095 printcharfun
, escapeflag
);
2096 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_buffer
)
2097 strout ("[local in buffer] ", -1, -1, printcharfun
, 0);
2099 strout ("[buffer] ", -1, -1, printcharfun
, 0);
2100 print_object (XBUFFER_LOCAL_VALUE (obj
)->buffer
,
2101 printcharfun
, escapeflag
);
2102 if (XBUFFER_LOCAL_VALUE (obj
)->check_frame
)
2104 if (XBUFFER_LOCAL_VALUE (obj
)->found_for_frame
)
2105 strout ("[local in frame] ", -1, -1, printcharfun
, 0);
2107 strout ("[frame] ", -1, -1, printcharfun
, 0);
2108 print_object (XBUFFER_LOCAL_VALUE (obj
)->frame
,
2109 printcharfun
, escapeflag
);
2111 strout ("[alist-elt] ", -1, -1, printcharfun
, 0);
2112 print_object (XCAR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
2113 printcharfun
, escapeflag
);
2114 strout ("[default-value] ", -1, -1, printcharfun
, 0);
2115 print_object (XCDR (XBUFFER_LOCAL_VALUE (obj
)->cdr
),
2116 printcharfun
, escapeflag
);
2120 case Lisp_Misc_Save_Value
:
2121 strout ("#<save_value ", -1, -1, printcharfun
, 0);
2122 sprintf(buf
, "ptr=0x%08lx int=%d",
2123 (unsigned long) XSAVE_VALUE (obj
)->pointer
,
2124 XSAVE_VALUE (obj
)->integer
);
2125 strout (buf
, -1, -1, printcharfun
, 0);
2137 /* We're in trouble if this happens!
2138 Probably should just abort () */
2139 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
, 0);
2141 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2142 else if (VECTORLIKEP (obj
))
2143 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
2145 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2146 strout (buf
, -1, -1, printcharfun
, 0);
2147 strout (" Save your buffers immediately and please report this bug>",
2148 -1, -1, printcharfun
, 0);
2156 /* Print a description of INTERVAL using PRINTCHARFUN.
2157 This is part of printing a string that has text properties. */
2160 print_interval (interval
, printcharfun
)
2162 Lisp_Object printcharfun
;
2165 print_object (make_number (interval
->position
), printcharfun
, 1);
2167 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2170 print_object (interval
->plist
, printcharfun
, 1);
2177 Qtemp_buffer_setup_hook
= intern ("temp-buffer-setup-hook");
2178 staticpro (&Qtemp_buffer_setup_hook
);
2180 DEFVAR_LISP ("standard-output", &Vstandard_output
,
2181 doc
: /* Output stream `print' uses by default for outputting a character.
2182 This may be any function of one argument.
2183 It may also be a buffer (output is inserted before point)
2184 or a marker (output is inserted and the marker is advanced)
2185 or the symbol t (output appears in the echo area). */);
2186 Vstandard_output
= Qt
;
2187 Qstandard_output
= intern ("standard-output");
2188 staticpro (&Qstandard_output
);
2190 DEFVAR_LISP ("float-output-format", &Vfloat_output_format
,
2191 doc
: /* The format descriptor string used to print floats.
2192 This is a %-spec like those accepted by `printf' in C,
2193 but with some restrictions. It must start with the two characters `%.'.
2194 After that comes an integer precision specification,
2195 and then a letter which controls the format.
2196 The letters allowed are `e', `f' and `g'.
2197 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2198 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2199 Use `g' to choose the shorter of those two formats for the number at hand.
2200 The precision in any of these cases is the number of digits following
2201 the decimal point. With `f', a precision of 0 means to omit the
2202 decimal point. 0 is not allowed with `e' or `g'.
2204 A value of nil means to use the shortest notation
2205 that represents the number without losing information. */);
2206 Vfloat_output_format
= Qnil
;
2207 Qfloat_output_format
= intern ("float-output-format");
2208 staticpro (&Qfloat_output_format
);
2210 DEFVAR_LISP ("print-length", &Vprint_length
,
2211 doc
: /* Maximum length of list to print before abbreviating.
2212 A value of nil means no limit. See also `eval-expression-print-length'. */);
2213 Vprint_length
= Qnil
;
2215 DEFVAR_LISP ("print-level", &Vprint_level
,
2216 doc
: /* Maximum depth of list nesting to print before abbreviating.
2217 A value of nil means no limit. See also `eval-expression-print-level'. */);
2218 Vprint_level
= Qnil
;
2220 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines
,
2221 doc
: /* Non-nil means print newlines in strings as `\\n'.
2222 Also print formfeeds as `\\f'. */);
2223 print_escape_newlines
= 0;
2225 DEFVAR_BOOL ("print-escape-nonascii", &print_escape_nonascii
,
2226 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2227 \(OOO is the octal representation of the character code.)
2228 Only single-byte characters are affected, and only in `prin1'.
2229 When the output goes in a multibyte buffer, this feature is
2230 enabled regardless of the value of the variable. */);
2231 print_escape_nonascii
= 0;
2233 DEFVAR_BOOL ("print-escape-multibyte", &print_escape_multibyte
,
2234 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2235 \(XXXX is the hex representation of the character code.)
2236 This affects only `prin1'. */);
2237 print_escape_multibyte
= 0;
2239 DEFVAR_BOOL ("print-quoted", &print_quoted
,
2240 doc
: /* Non-nil means print quoted forms with reader syntax.
2241 I.e., (quote foo) prints as 'foo, (function foo) as #'foo, and backquoted
2242 forms print as in the new syntax. */);
2245 DEFVAR_LISP ("print-gensym", &Vprint_gensym
,
2246 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2247 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2248 When the uninterned symbol appears within a recursive data structure,
2249 and the symbol appears more than once, in addition use the #N# and #N=
2250 constructs as needed, so that multiple references to the same symbol are
2251 shared once again when the text is read back. */);
2252 Vprint_gensym
= Qnil
;
2254 DEFVAR_LISP ("print-circle", &Vprint_circle
,
2255 doc
: /* *Non-nil means print recursive structures using #N= and #N# syntax.
2256 If nil, printing proceeds recursively and may lead to
2257 `max-lisp-eval-depth' being exceeded or an error may occur:
2258 \"Apparently circular structure being printed.\" Also see
2259 `print-length' and `print-level'.
2260 If non-nil, shared substructures anywhere in the structure are printed
2261 with `#N=' before the first occurrence (in the order of the print
2262 representation) and `#N#' in place of each subsequent occurrence,
2263 where N is a positive decimal integer. */);
2264 Vprint_circle
= Qnil
;
2266 DEFVAR_LISP ("print-continuous-numbering", &Vprint_continuous_numbering
,
2267 doc
: /* *Non-nil means number continuously across print calls.
2268 This affects the numbers printed for #N= labels and #M# references.
2269 See also `print-circle', `print-gensym', and `print-number-table'.
2270 This variable should not be set with `setq'; bind it with a `let' instead. */);
2271 Vprint_continuous_numbering
= Qnil
;
2273 DEFVAR_LISP ("print-number-table", &Vprint_number_table
,
2274 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2275 The Lisp printer uses this vector to detect Lisp objects referenced more
2278 When you bind `print-continuous-numbering' to t, you should probably
2279 also bind `print-number-table' to nil. This ensures that the value of
2280 `print-number-table' can be garbage-collected once the printing is
2281 done. If all elements of `print-number-table' are nil, it means that
2282 the printing done so far has not found any shared structure or objects
2283 that need to be recorded in the table. */);
2284 Vprint_number_table
= Qnil
;
2286 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2287 staticpro (&Vprin1_to_string_buffer
);
2290 defsubr (&Sprin1_to_string
);
2291 defsubr (&Serror_message_string
);
2295 defsubr (&Swrite_char
);
2296 defsubr (&Sexternal_debugging_output
);
2297 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2298 defsubr (&Sredirect_debugging_output
);
2301 Qexternal_debugging_output
= intern ("external-debugging-output");
2302 staticpro (&Qexternal_debugging_output
);
2304 Qprint_escape_newlines
= intern ("print-escape-newlines");
2305 staticpro (&Qprint_escape_newlines
);
2307 Qprint_escape_multibyte
= intern ("print-escape-multibyte");
2308 staticpro (&Qprint_escape_multibyte
);
2310 Qprint_escape_nonascii
= intern ("print-escape-nonascii");
2311 staticpro (&Qprint_escape_nonascii
);
2313 defsubr (&Swith_output_to_temp_buffer
);
2316 /* arch-tag: bc797170-94ae-41de-86e3-75e20f8f7a39
2317 (do not change this comment) */