1 /* Lisp object printing and output streams.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2011
4 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 3 of the License, or
11 (at your option) any later version.
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. If not, see <http://www.gnu.org/licenses/>. */
27 #include "character.h"
33 #include "dispextern.h"
35 #include "intervals.h"
36 #include "blockinput.h"
37 #include "termhooks.h" /* For struct terminal. */
40 Lisp_Object Qstandard_output
;
42 static Lisp_Object Qtemp_buffer_setup_hook
;
44 /* These are used to print like we read. */
46 static Lisp_Object Qfloat_output_format
;
55 /* Default to values appropriate for IEEE floating point. */
60 /* Avoid actual stack overflow in print. */
61 static int print_depth
;
63 /* Level of nesting inside outputting backquote in new style. */
64 static int new_backquote_output
;
66 /* Detect most circularities to print finite output. */
67 #define PRINT_CIRCLE 200
68 static Lisp_Object being_printed
[PRINT_CIRCLE
];
70 /* When printing into a buffer, first we put the text in this
71 block, then insert it all at once. */
72 static char *print_buffer
;
74 /* Size allocated in print_buffer. */
75 static EMACS_INT print_buffer_size
;
76 /* Chars stored in print_buffer. */
77 static EMACS_INT print_buffer_pos
;
78 /* Bytes stored in print_buffer. */
79 static EMACS_INT print_buffer_pos_byte
;
81 Lisp_Object Qprint_escape_newlines
;
82 static Lisp_Object Qprint_escape_multibyte
, Qprint_escape_nonascii
;
84 /* Vprint_number_table is a table, that keeps objects that are going to
85 be printed, to allow use of #n= and #n# to express sharing.
86 For any given object, the table can give the following values:
87 t the object will be printed only once.
88 -N the object will be printed several times and will take number N.
89 N the object has been printed so we can refer to it as #N#.
90 print_number_index holds the largest N already used.
91 N has to be striclty larger than 0 since we need to distinguish -N. */
92 static int print_number_index
;
93 static void print_interval (INTERVAL interval
, Lisp_Object printcharfun
);
95 /* GDB resets this to zero on W32 to disable OutputDebugString calls. */
96 int print_output_debug_flag EXTERNALLY_VISIBLE
= 1;
99 /* Low level output routines for characters and strings */
101 /* Lisp functions to do output using a stream
102 must have the stream in a variable called printcharfun
103 and must start with PRINTPREPARE, end with PRINTFINISH,
104 and use PRINTDECLARE to declare common variables.
105 Use PRINTCHAR to output one character,
106 or call strout to output a block of characters. */
108 #define PRINTDECLARE \
109 struct buffer *old = current_buffer; \
110 EMACS_INT old_point = -1, start_point = -1; \
111 EMACS_INT old_point_byte = -1, start_point_byte = -1; \
112 int specpdl_count = SPECPDL_INDEX (); \
113 int free_print_buffer = 0; \
114 int multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters)); \
117 #define PRINTPREPARE \
118 original = printcharfun; \
119 if (NILP (printcharfun)) printcharfun = Qt; \
120 if (BUFFERP (printcharfun)) \
122 if (XBUFFER (printcharfun) != current_buffer) \
123 Fset_buffer (printcharfun); \
124 printcharfun = Qnil; \
126 if (MARKERP (printcharfun)) \
128 EMACS_INT marker_pos; \
129 if (! XMARKER (printcharfun)->buffer) \
130 error ("Marker does not point anywhere"); \
131 if (XMARKER (printcharfun)->buffer != current_buffer) \
132 set_buffer_internal (XMARKER (printcharfun)->buffer); \
133 marker_pos = marker_position (printcharfun); \
134 if (marker_pos < BEGV || marker_pos > ZV) \
135 error ("Marker is outside the accessible part of the buffer"); \
137 old_point_byte = PT_BYTE; \
138 SET_PT_BOTH (marker_pos, \
139 marker_byte_position (printcharfun)); \
141 start_point_byte = PT_BYTE; \
142 printcharfun = Qnil; \
144 if (NILP (printcharfun)) \
146 Lisp_Object string; \
147 if (NILP (BVAR (current_buffer, enable_multibyte_characters)) \
148 && ! print_escape_multibyte) \
149 specbind (Qprint_escape_multibyte, Qt); \
150 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)) \
151 && ! print_escape_nonascii) \
152 specbind (Qprint_escape_nonascii, Qt); \
153 if (print_buffer != 0) \
155 string = make_string_from_bytes (print_buffer, \
157 print_buffer_pos_byte); \
158 record_unwind_protect (print_unwind, string); \
162 print_buffer_size = 1000; \
163 print_buffer = (char *) xmalloc (print_buffer_size); \
164 free_print_buffer = 1; \
166 print_buffer_pos = 0; \
167 print_buffer_pos_byte = 0; \
169 if (EQ (printcharfun, Qt) && ! noninteractive) \
170 setup_echo_area_for_printing (multibyte);
172 #define PRINTFINISH \
173 if (NILP (printcharfun)) \
175 if (print_buffer_pos != print_buffer_pos_byte \
176 && NILP (BVAR (current_buffer, enable_multibyte_characters))) \
178 unsigned char *temp \
179 = (unsigned char *) alloca (print_buffer_pos + 1); \
180 copy_text ((unsigned char *) print_buffer, temp, \
181 print_buffer_pos_byte, 1, 0); \
182 insert_1_both ((char *) temp, print_buffer_pos, \
183 print_buffer_pos, 0, 1, 0); \
186 insert_1_both (print_buffer, print_buffer_pos, \
187 print_buffer_pos_byte, 0, 1, 0); \
188 signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
190 if (free_print_buffer) \
192 xfree (print_buffer); \
195 unbind_to (specpdl_count, Qnil); \
196 if (MARKERP (original)) \
197 set_marker_both (original, Qnil, PT, PT_BYTE); \
198 if (old_point >= 0) \
199 SET_PT_BOTH (old_point + (old_point >= start_point \
200 ? PT - start_point : 0), \
201 old_point_byte + (old_point_byte >= start_point_byte \
202 ? PT_BYTE - start_point_byte : 0)); \
203 if (old != current_buffer) \
204 set_buffer_internal (old);
206 #define PRINTCHAR(ch) printchar (ch, printcharfun)
208 /* This is used to restore the saved contents of print_buffer
209 when there is a recursive call to print. */
212 print_unwind (Lisp_Object saved_text
)
214 memcpy (print_buffer
, SDATA (saved_text
), SCHARS (saved_text
));
219 /* Print character CH using method FUN. FUN nil means print to
220 print_buffer. FUN t means print to echo area or stdout if
221 non-interactive. If FUN is neither nil nor t, call FUN with CH as
225 printchar (unsigned int ch
, Lisp_Object fun
)
227 if (!NILP (fun
) && !EQ (fun
, Qt
))
228 call1 (fun
, make_number (ch
));
231 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
232 int len
= CHAR_STRING (ch
, str
);
238 if (print_buffer_pos_byte
+ len
>= print_buffer_size
)
239 print_buffer
= (char *) xrealloc (print_buffer
,
240 print_buffer_size
*= 2);
241 memcpy (print_buffer
+ print_buffer_pos_byte
, str
, len
);
242 print_buffer_pos
+= 1;
243 print_buffer_pos_byte
+= len
;
245 else if (noninteractive
)
247 fwrite (str
, 1, len
, stdout
);
248 noninteractive_need_newline
= 1;
253 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
255 setup_echo_area_for_printing (multibyte_p
);
257 message_dolog ((char *) str
, len
, 0, multibyte_p
);
263 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
264 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
265 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
266 print_buffer. PRINTCHARFUN t means output to the echo area or to
267 stdout if non-interactive. If neither nil nor t, call Lisp
268 function PRINTCHARFUN for each character printed. MULTIBYTE
269 non-zero means PTR contains multibyte characters.
271 In the case where PRINTCHARFUN is nil, it is safe for PTR to point
272 to data in a Lisp string. Otherwise that is not safe. */
275 strout (const char *ptr
, EMACS_INT size
, EMACS_INT size_byte
,
276 Lisp_Object printcharfun
)
279 size_byte
= size
= strlen (ptr
);
281 if (NILP (printcharfun
))
283 if (print_buffer_pos_byte
+ size_byte
> print_buffer_size
)
285 print_buffer_size
= print_buffer_size
* 2 + size_byte
;
286 print_buffer
= (char *) xrealloc (print_buffer
,
289 memcpy (print_buffer
+ print_buffer_pos_byte
, ptr
, size_byte
);
290 print_buffer_pos
+= size
;
291 print_buffer_pos_byte
+= size_byte
;
293 else if (noninteractive
&& EQ (printcharfun
, Qt
))
295 fwrite (ptr
, 1, size_byte
, stdout
);
296 noninteractive_need_newline
= 1;
298 else if (EQ (printcharfun
, Qt
))
300 /* Output to echo area. We're trying to avoid a little overhead
301 here, that's the reason we don't call printchar to do the
305 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
307 setup_echo_area_for_printing (multibyte_p
);
308 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
310 if (size
== size_byte
)
312 for (i
= 0; i
< size
; ++i
)
313 insert_char ((unsigned char) *ptr
++);
318 for (i
= 0; i
< size_byte
; i
+= len
)
320 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
328 /* PRINTCHARFUN is a Lisp function. */
331 if (size
== size_byte
)
333 while (i
< size_byte
)
341 while (i
< size_byte
)
343 /* Here, we must convert each multi-byte form to the
344 corresponding character code before handing it to
347 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
356 /* Print the contents of a string STRING using PRINTCHARFUN.
357 It isn't safe to use strout in many cases,
358 because printing one char can relocate. */
361 print_string (Lisp_Object string
, Lisp_Object printcharfun
)
363 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
367 if (print_escape_nonascii
)
368 string
= string_escape_byte8 (string
);
370 if (STRING_MULTIBYTE (string
))
371 chars
= SCHARS (string
);
372 else if (! print_escape_nonascii
373 && (EQ (printcharfun
, Qt
)
374 ? ! NILP (BVAR (&buffer_defaults
, enable_multibyte_characters
))
375 : ! NILP (BVAR (current_buffer
, enable_multibyte_characters
))))
377 /* If unibyte string STRING contains 8-bit codes, we must
378 convert STRING to a multibyte string containing the same
383 chars
= SBYTES (string
);
384 bytes
= parse_str_to_multibyte (SDATA (string
), chars
);
387 newstr
= make_uninit_multibyte_string (chars
, bytes
);
388 memcpy (SDATA (newstr
), SDATA (string
), chars
);
389 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
394 chars
= SBYTES (string
);
396 if (EQ (printcharfun
, Qt
))
398 /* Output to echo area. */
399 EMACS_INT nbytes
= SBYTES (string
);
402 /* Copy the string contents so that relocation of STRING by
403 GC does not cause trouble. */
406 SAFE_ALLOCA (buffer
, char *, nbytes
);
407 memcpy (buffer
, SDATA (string
), nbytes
);
409 strout (buffer
, chars
, SBYTES (string
), printcharfun
);
414 /* No need to copy, since output to print_buffer can't GC. */
415 strout (SSDATA (string
), chars
, SBYTES (string
), printcharfun
);
419 /* Otherwise, string may be relocated by printing one char.
420 So re-fetch the string address for each character. */
422 EMACS_INT size
= SCHARS (string
);
423 EMACS_INT size_byte
= SBYTES (string
);
426 if (size
== size_byte
)
427 for (i
= 0; i
< size
; i
++)
428 PRINTCHAR (SREF (string
, i
));
430 for (i
= 0; i
< size_byte
; )
432 /* Here, we must convert each multi-byte form to the
433 corresponding character code before handing it to PRINTCHAR. */
435 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
, len
);
443 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
444 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
445 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
446 (Lisp_Object character
, Lisp_Object printcharfun
)
450 if (NILP (printcharfun
))
451 printcharfun
= Vstandard_output
;
452 CHECK_NUMBER (character
);
454 PRINTCHAR (XINT (character
));
459 /* Used from outside of print.c to print a block of SIZE
460 single-byte chars at DATA on the default output stream.
461 Do not use this on the contents of a Lisp string. */
464 write_string (const char *data
, int size
)
467 Lisp_Object printcharfun
;
469 printcharfun
= Vstandard_output
;
472 strout (data
, size
, size
, printcharfun
);
476 /* Used to print a block of SIZE single-byte chars at DATA on a
477 specified stream PRINTCHARFUN.
478 Do not use this on the contents of a Lisp string. */
481 write_string_1 (const char *data
, int size
, Lisp_Object printcharfun
)
486 strout (data
, size
, size
, printcharfun
);
492 temp_output_buffer_setup (const char *bufname
)
494 int count
= SPECPDL_INDEX ();
495 register struct buffer
*old
= current_buffer
;
496 register Lisp_Object buf
;
498 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
500 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
502 Fkill_all_local_variables ();
503 delete_all_overlays (current_buffer
);
504 BVAR (current_buffer
, directory
) = BVAR (old
, directory
);
505 BVAR (current_buffer
, read_only
) = Qnil
;
506 BVAR (current_buffer
, filename
) = Qnil
;
507 BVAR (current_buffer
, undo_list
) = Qt
;
508 eassert (current_buffer
->overlays_before
== NULL
);
509 eassert (current_buffer
->overlays_after
== NULL
);
510 BVAR (current_buffer
, enable_multibyte_characters
)
511 = BVAR (&buffer_defaults
, enable_multibyte_characters
);
512 specbind (Qinhibit_read_only
, Qt
);
513 specbind (Qinhibit_modification_hooks
, Qt
);
515 XSETBUFFER (buf
, current_buffer
);
517 Frun_hooks (1, &Qtemp_buffer_setup_hook
);
519 unbind_to (count
, Qnil
);
521 specbind (Qstandard_output
, buf
);
524 static void print (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
);
525 static void print_preprocess (Lisp_Object obj
);
526 static void print_preprocess_string (INTERVAL interval
, Lisp_Object arg
);
527 static void print_object (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
);
529 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
530 doc
: /* Output a newline to stream PRINTCHARFUN.
531 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
532 (Lisp_Object printcharfun
)
536 if (NILP (printcharfun
))
537 printcharfun
= Vstandard_output
;
544 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
545 doc
: /* Output the printed representation of OBJECT, any Lisp object.
546 Quoting characters are printed when needed to make output that `read'
547 can handle, whenever this is possible. For complex objects, the behavior
548 is controlled by `print-level' and `print-length', which see.
550 OBJECT is any of the Lisp data types: a number, a string, a symbol,
551 a list, a buffer, a window, a frame, etc.
553 A printed representation of an object is text which describes that object.
555 Optional argument PRINTCHARFUN is the output stream, which can be one
558 - a buffer, in which case output is inserted into that buffer at point;
559 - a marker, in which case output is inserted at marker's position;
560 - a function, in which case that function is called once for each
561 character of OBJECT's printed representation;
562 - a symbol, in which case that symbol's function definition is called; or
563 - t, in which case the output is displayed in the echo area.
565 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
567 (Lisp_Object object
, Lisp_Object printcharfun
)
571 if (NILP (printcharfun
))
572 printcharfun
= Vstandard_output
;
574 print (object
, printcharfun
, 1);
579 /* a buffer which is used to hold output being built by prin1-to-string */
580 Lisp_Object Vprin1_to_string_buffer
;
582 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
583 doc
: /* Return a string containing the printed representation of OBJECT.
584 OBJECT can be any Lisp object. This function outputs quoting characters
585 when necessary to make output that `read' can handle, whenever possible,
586 unless the optional second argument NOESCAPE is non-nil. For complex objects,
587 the behavior is controlled by `print-level' and `print-length', which see.
589 OBJECT is any of the Lisp data types: a number, a string, a symbol,
590 a list, a buffer, a window, a frame, etc.
592 A printed representation of an object is text which describes that object. */)
593 (Lisp_Object object
, Lisp_Object noescape
)
595 Lisp_Object printcharfun
;
596 /* struct gcpro gcpro1, gcpro2; */
597 Lisp_Object save_deactivate_mark
;
598 int count
= SPECPDL_INDEX ();
599 struct buffer
*previous
;
601 specbind (Qinhibit_modification_hooks
, Qt
);
606 /* Save and restore this--we are altering a buffer
607 but we don't want to deactivate the mark just for that.
608 No need for specbind, since errors deactivate the mark. */
609 save_deactivate_mark
= Vdeactivate_mark
;
610 /* GCPRO2 (object, save_deactivate_mark); */
613 printcharfun
= Vprin1_to_string_buffer
;
615 print (object
, printcharfun
, NILP (noescape
));
616 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
620 previous
= current_buffer
;
621 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
622 object
= Fbuffer_string ();
623 if (SBYTES (object
) == SCHARS (object
))
624 STRING_SET_UNIBYTE (object
);
626 /* Note that this won't make prepare_to_modify_buffer call
627 ask-user-about-supersession-threat because this buffer
628 does not visit a file. */
630 set_buffer_internal (previous
);
632 Vdeactivate_mark
= save_deactivate_mark
;
636 return unbind_to (count
, object
);
639 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
640 doc
: /* Output the printed representation of OBJECT, any Lisp object.
641 No quoting characters are used; no delimiters are printed around
642 the contents of strings.
644 OBJECT is any of the Lisp data types: a number, a string, a symbol,
645 a list, a buffer, a window, a frame, etc.
647 A printed representation of an object is text which describes that object.
649 Optional argument PRINTCHARFUN is the output stream, which can be one
652 - a buffer, in which case output is inserted into that buffer at point;
653 - a marker, in which case output is inserted at marker's position;
654 - a function, in which case that function is called once for each
655 character of OBJECT's printed representation;
656 - a symbol, in which case that symbol's function definition is called; or
657 - t, in which case the output is displayed in the echo area.
659 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
661 (Lisp_Object object
, Lisp_Object printcharfun
)
665 if (NILP (printcharfun
))
666 printcharfun
= Vstandard_output
;
668 print (object
, printcharfun
, 0);
673 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
674 doc
: /* Output the printed representation of OBJECT, with newlines around it.
675 Quoting characters are printed when needed to make output that `read'
676 can handle, whenever this is possible. For complex objects, the behavior
677 is controlled by `print-level' and `print-length', which see.
679 OBJECT is any of the Lisp data types: a number, a string, a symbol,
680 a list, a buffer, a window, a frame, etc.
682 A printed representation of an object is text which describes that object.
684 Optional argument PRINTCHARFUN is the output stream, which can be one
687 - a buffer, in which case output is inserted into that buffer at point;
688 - a marker, in which case output is inserted at marker's position;
689 - a function, in which case that function is called once for each
690 character of OBJECT's printed representation;
691 - a symbol, in which case that symbol's function definition is called; or
692 - t, in which case the output is displayed in the echo area.
694 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
696 (Lisp_Object object
, Lisp_Object printcharfun
)
701 if (NILP (printcharfun
))
702 printcharfun
= Vstandard_output
;
706 print (object
, printcharfun
, 1);
713 /* The subroutine object for external-debugging-output is kept here
714 for the convenience of the debugger. */
715 Lisp_Object Qexternal_debugging_output
;
717 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
718 doc
: /* Write CHARACTER to stderr.
719 You can call print while debugging emacs, and pass it this function
720 to make it write to the debugging output. */)
721 (Lisp_Object character
)
723 CHECK_NUMBER (character
);
724 putc ((int) XINT (character
), stderr
);
727 /* Send the output to a debugger (nothing happens if there isn't one). */
728 if (print_output_debug_flag
)
730 char buf
[2] = {(char) XINT (character
), '\0'};
731 OutputDebugString (buf
);
738 /* This function is never called. Its purpose is to prevent
739 print_output_debug_flag from being optimized away. */
741 extern void debug_output_compilation_hack (int) EXTERNALLY_VISIBLE
;
743 debug_output_compilation_hack (int x
)
745 print_output_debug_flag
= x
;
748 #if defined (GNU_LINUX)
750 /* This functionality is not vitally important in general, so we rely on
751 non-portable ability to use stderr as lvalue. */
753 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
755 static FILE *initial_stderr_stream
= NULL
;
757 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
759 "FDebug output file: \nP",
760 doc
: /* Redirect debugging output (stderr stream) to file FILE.
761 If FILE is nil, reset target to the initial stderr stream.
762 Optional arg APPEND non-nil (interactively, with prefix arg) means
763 append to existing target file. */)
764 (Lisp_Object file
, Lisp_Object append
)
766 if (initial_stderr_stream
!= NULL
)
772 stderr
= initial_stderr_stream
;
773 initial_stderr_stream
= NULL
;
777 file
= Fexpand_file_name (file
, Qnil
);
778 initial_stderr_stream
= stderr
;
779 stderr
= fopen (SSDATA (file
), NILP (append
) ? "w" : "a");
782 stderr
= initial_stderr_stream
;
783 initial_stderr_stream
= NULL
;
784 report_file_error ("Cannot open debugging output stream",
790 #endif /* GNU_LINUX */
793 /* This is the interface for debugging printing. */
796 debug_print (Lisp_Object arg
)
798 Fprin1 (arg
, Qexternal_debugging_output
);
799 fprintf (stderr
, "\r\n");
802 void safe_debug_print (Lisp_Object
) EXTERNALLY_VISIBLE
;
804 safe_debug_print (Lisp_Object arg
)
806 int valid
= valid_lisp_object_p (arg
);
811 fprintf (stderr
, "#<%s_LISP_OBJECT 0x%08lx>\r\n",
812 !valid
? "INVALID" : "SOME",
813 (unsigned long) XHASH (arg
)
818 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
820 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
821 See Info anchor `(elisp)Definition of signal' for some details on how this
822 error message is constructed. */)
825 struct buffer
*old
= current_buffer
;
829 /* If OBJ is (error STRING), just return STRING.
830 That is not only faster, it also avoids the need to allocate
831 space here when the error is due to memory full. */
832 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
833 && CONSP (XCDR (obj
))
834 && STRINGP (XCAR (XCDR (obj
)))
835 && NILP (XCDR (XCDR (obj
))))
836 return XCAR (XCDR (obj
));
838 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
840 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
841 value
= Fbuffer_string ();
845 set_buffer_internal (old
);
851 /* Print an error message for the error DATA onto Lisp output stream
852 STREAM (suitable for the print functions).
853 CONTEXT is a C string describing the context of the error.
854 CALLER is the Lisp function inside which the error was signaled. */
857 print_error_message (Lisp_Object data
, Lisp_Object stream
, const char *context
,
860 Lisp_Object errname
, errmsg
, file_error
, tail
;
865 write_string_1 (context
, -1, stream
);
867 /* If we know from where the error was signaled, show it in
869 if (!NILP (caller
) && SYMBOLP (caller
))
871 Lisp_Object cname
= SYMBOL_NAME (caller
);
872 char *name
= alloca (SBYTES (cname
));
873 memcpy (name
, SDATA (cname
), SBYTES (cname
));
874 message_dolog (name
, SBYTES (cname
), 0, 0);
875 message_dolog (": ", 2, 0, 0);
878 errname
= Fcar (data
);
880 if (EQ (errname
, Qerror
))
885 errmsg
= Fcar (data
);
890 Lisp_Object error_conditions
;
891 errmsg
= Fget (errname
, Qerror_message
);
892 error_conditions
= Fget (errname
, Qerror_conditions
);
893 file_error
= Fmemq (Qfile_error
, error_conditions
);
896 /* Print an error message including the data items. */
898 tail
= Fcdr_safe (data
);
901 /* For file-error, make error message by concatenating
902 all the data items. They are all strings. */
903 if (!NILP (file_error
) && CONSP (tail
))
904 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
906 if (STRINGP (errmsg
))
907 Fprinc (errmsg
, stream
);
909 write_string_1 ("peculiar error", -1, stream
);
911 for (i
= 0; CONSP (tail
); tail
= XCDR (tail
), i
= 1)
915 write_string_1 (i
? ", " : ": ", 2, stream
);
917 if (!NILP (file_error
) || EQ (errname
, Qend_of_file
))
918 Fprinc (obj
, stream
);
920 Fprin1 (obj
, stream
);
929 * The buffer should be at least as large as the max string size of the
930 * largest float, printed in the biggest notation. This is undoubtedly
931 * 20d float_output_format, with the negative of the C-constant "HUGE"
934 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
936 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
937 * case of -1e307 in 20d float_output_format. What is one to do (short of
938 * re-writing _doprnt to be more sane)?
940 * Given the above, the buffer must be least FLOAT_TO_STRING_BUFSIZE bytes.
944 float_to_string (char *buf
, double data
)
949 /* Check for plus infinity in a way that won't lose
950 if there is no plus infinity. */
951 if (data
== data
/ 2 && data
> 1.0)
953 strcpy (buf
, "1.0e+INF");
956 /* Likewise for minus infinity. */
957 if (data
== data
/ 2 && data
< -1.0)
959 strcpy (buf
, "-1.0e+INF");
962 /* Check for NaN in a way that won't fail if there are no NaNs. */
963 if (! (data
* 0.0 >= 0.0))
965 /* Prepend "-" if the NaN's sign bit is negative.
966 The sign bit of a double is the bit that is 1 in -0.0. */
968 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
970 u_minus_zero
.d
= - 0.0;
971 for (i
= 0; i
< sizeof (double); i
++)
972 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
978 strcpy (buf
, "0.0e+NaN");
982 if (NILP (Vfloat_output_format
)
983 || !STRINGP (Vfloat_output_format
))
986 /* Generate the fewest number of digits that represent the
987 floating point value without losing information. */
988 dtoastr (buf
, FLOAT_TO_STRING_BUFSIZE
- 2, 0, 0, data
);
989 /* The decimal point must be printed, or the byte compiler can
990 get confused (Bug#8033). */
995 /* Check that the spec we have is fully valid.
996 This means not only valid for printf,
997 but meant for floats, and reasonable. */
998 cp
= SSDATA (Vfloat_output_format
);
1007 /* Check the width specification. */
1009 if ('0' <= *cp
&& *cp
<= '9')
1013 width
= (width
* 10) + (*cp
++ - '0');
1014 while (*cp
>= '0' && *cp
<= '9');
1016 /* A precision of zero is valid only for %f. */
1018 || (width
== 0 && *cp
!= 'f'))
1022 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1028 sprintf (buf
, SSDATA (Vfloat_output_format
), data
);
1031 /* Make sure there is a decimal point with digit after, or an
1032 exponent, so that the value is readable as a float. But don't do
1033 this with "%.0f"; it's valid for that not to produce a decimal
1034 point. Note that width can be 0 only for %.0f. */
1037 for (cp
= buf
; *cp
; cp
++)
1038 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1041 if (*cp
== '.' && cp
[1] == 0)
1057 print (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
)
1059 new_backquote_output
= 0;
1061 /* Reset print_number_index and Vprint_number_table only when
1062 the variable Vprint_continuous_numbering is nil. Otherwise,
1063 the values of these variables will be kept between several
1065 if (NILP (Vprint_continuous_numbering
)
1066 || NILP (Vprint_number_table
))
1068 print_number_index
= 0;
1069 Vprint_number_table
= Qnil
;
1072 /* Construct Vprint_number_table for print-gensym and print-circle. */
1073 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1075 /* Construct Vprint_number_table.
1076 This increments print_number_index for the objects added. */
1078 print_preprocess (obj
);
1080 if (HASH_TABLE_P (Vprint_number_table
))
1081 { /* Remove unnecessary objects, which appear only once in OBJ;
1082 that is, whose status is Qt.
1083 Maybe a better way to do that is to copy elements to
1084 a new hash table. */
1085 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vprint_number_table
);
1088 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
1089 if (!NILP (HASH_HASH (h
, i
))
1090 && EQ (HASH_VALUE (h
, i
), Qt
))
1091 Fremhash (HASH_KEY (h
, i
), Vprint_number_table
);
1096 print_object (obj
, printcharfun
, escapeflag
);
1099 #define PRINT_CIRCLE_CANDIDATE_P(obj) \
1100 (STRINGP (obj) || CONSP (obj) \
1101 || (VECTORLIKEP (obj) \
1102 && (VECTORP (obj) || COMPILEDP (obj) \
1103 || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \
1104 || HASH_TABLE_P (obj) || FONTP (obj))) \
1105 || (! NILP (Vprint_gensym) \
1107 && !SYMBOL_INTERNED_P (obj)))
1109 /* Construct Vprint_number_table according to the structure of OBJ.
1110 OBJ itself and all its elements will be added to Vprint_number_table
1111 recursively if it is a list, vector, compiled function, char-table,
1112 string (its text properties will be traced), or a symbol that has
1113 no obarray (this is for the print-gensym feature).
1114 The status fields of Vprint_number_table mean whether each object appears
1115 more than once in OBJ: Qnil at the first time, and Qt after that . */
1117 print_preprocess (Lisp_Object obj
)
1122 Lisp_Object halftail
;
1124 /* Give up if we go so deep that print_object will get an error. */
1125 /* See similar code in print_object. */
1126 if (print_depth
>= PRINT_CIRCLE
)
1127 error ("Apparently circular structure being printed");
1129 /* Avoid infinite recursion for circular nested structure
1130 in the case where Vprint_circle is nil. */
1131 if (NILP (Vprint_circle
))
1133 for (i
= 0; i
< print_depth
; i
++)
1134 if (EQ (obj
, being_printed
[i
]))
1136 being_printed
[print_depth
] = obj
;
1143 if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1145 if (!HASH_TABLE_P (Vprint_number_table
))
1147 Lisp_Object args
[2];
1150 Vprint_number_table
= Fmake_hash_table (2, args
);
1153 /* In case print-circle is nil and print-gensym is t,
1154 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1155 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1157 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1159 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1160 always print the gensym with a number. This is a special for
1161 the lisp function byte-compile-output-docform. */
1162 || (!NILP (Vprint_continuous_numbering
)
1164 && !SYMBOL_INTERNED_P (obj
)))
1165 { /* OBJ appears more than once. Let's remember that. */
1166 if (!INTEGERP (num
))
1168 print_number_index
++;
1169 /* Negative number indicates it hasn't been printed yet. */
1170 Fputhash (obj
, make_number (- print_number_index
),
1171 Vprint_number_table
);
1177 /* OBJ is not yet recorded. Let's add to the table. */
1178 Fputhash (obj
, Qt
, Vprint_number_table
);
1181 switch (XTYPE (obj
))
1184 /* A string may have text properties, which can be circular. */
1185 traverse_intervals_noorder (STRING_INTERVALS (obj
),
1186 print_preprocess_string
, Qnil
);
1190 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1191 just as in print_object. */
1192 if (loop_count
&& EQ (obj
, halftail
))
1194 print_preprocess (XCAR (obj
));
1197 if (!(loop_count
& 1))
1198 halftail
= XCDR (halftail
);
1201 case Lisp_Vectorlike
:
1202 size
= XVECTOR (obj
)->size
;
1203 if (size
& PSEUDOVECTOR_FLAG
)
1204 size
&= PSEUDOVECTOR_SIZE_MASK
;
1205 for (i
= 0; i
< size
; i
++)
1206 print_preprocess (XVECTOR (obj
)->contents
[i
]);
1207 if (HASH_TABLE_P (obj
))
1208 { /* For hash tables, the key_and_value slot is past
1209 `size' because it needs to be marked specially in case
1210 the table is weak. */
1211 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1212 print_preprocess (h
->key_and_value
);
1224 print_preprocess_string (INTERVAL interval
, Lisp_Object arg
)
1226 print_preprocess (interval
->plist
);
1229 static void print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
);
1231 #define PRINT_STRING_NON_CHARSET_FOUND 1
1232 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1234 /* Bitwise or of the above macros. */
1235 static int print_check_string_result
;
1238 print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
)
1242 if (NILP (interval
->plist
)
1243 || (print_check_string_result
== (PRINT_STRING_NON_CHARSET_FOUND
1244 | PRINT_STRING_UNSAFE_CHARSET_FOUND
)))
1246 for (val
= interval
->plist
; CONSP (val
) && ! EQ (XCAR (val
), Qcharset
);
1247 val
= XCDR (XCDR (val
)));
1250 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1253 if (! (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
))
1255 if (! EQ (val
, interval
->plist
)
1256 || CONSP (XCDR (XCDR (val
))))
1257 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1259 if (NILP (Vprint_charset_text_property
)
1260 || ! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1263 EMACS_INT charpos
= interval
->position
;
1264 EMACS_INT bytepos
= string_char_to_byte (string
, charpos
);
1265 Lisp_Object charset
;
1267 charset
= XCAR (XCDR (val
));
1268 for (i
= 0; i
< LENGTH (interval
); i
++)
1270 FETCH_STRING_CHAR_ADVANCE (c
, string
, charpos
, bytepos
);
1271 if (! ASCII_CHAR_P (c
)
1272 && ! EQ (CHARSET_NAME (CHAR_CHARSET (c
)), charset
))
1274 print_check_string_result
|= PRINT_STRING_UNSAFE_CHARSET_FOUND
;
1281 /* The value is (charset . nil). */
1282 static Lisp_Object print_prune_charset_plist
;
1285 print_prune_string_charset (Lisp_Object string
)
1287 print_check_string_result
= 0;
1288 traverse_intervals (STRING_INTERVALS (string
), 0,
1289 print_check_string_charset_prop
, string
);
1290 if (! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1292 string
= Fcopy_sequence (string
);
1293 if (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
)
1295 if (NILP (print_prune_charset_plist
))
1296 print_prune_charset_plist
= Fcons (Qcharset
, Qnil
);
1297 Fremove_text_properties (make_number (0),
1298 make_number (SCHARS (string
)),
1299 print_prune_charset_plist
, string
);
1302 Fset_text_properties (make_number (0), make_number (SCHARS (string
)),
1309 print_object (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
)
1315 /* See similar code in print_preprocess. */
1316 if (print_depth
>= PRINT_CIRCLE
)
1317 error ("Apparently circular structure being printed");
1319 /* Detect circularities and truncate them. */
1320 if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1322 if (NILP (Vprint_circle
) && NILP (Vprint_gensym
))
1324 /* Simple but incomplete way. */
1326 for (i
= 0; i
< print_depth
; i
++)
1327 if (EQ (obj
, being_printed
[i
]))
1329 sprintf (buf
, "#%d", i
);
1330 strout (buf
, -1, -1, printcharfun
);
1333 being_printed
[print_depth
] = obj
;
1337 /* With the print-circle feature. */
1338 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1343 { /* Add a prefix #n= if OBJ has not yet been printed;
1344 that is, its status field is nil. */
1345 sprintf (buf
, "#%d=", -n
);
1346 strout (buf
, -1, -1, printcharfun
);
1347 /* OBJ is going to be printed. Remember that fact. */
1348 Fputhash (obj
, make_number (- n
), Vprint_number_table
);
1352 /* Just print #n# if OBJ has already been printed. */
1353 sprintf (buf
, "#%d#", n
);
1354 strout (buf
, -1, -1, printcharfun
);
1363 switch (XTYPE (obj
))
1366 if (sizeof (int) == sizeof (EMACS_INT
))
1367 sprintf (buf
, "%d", (int) XINT (obj
));
1368 else if (sizeof (long) == sizeof (EMACS_INT
))
1369 sprintf (buf
, "%ld", (long) XINT (obj
));
1372 strout (buf
, -1, -1, printcharfun
);
1377 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
1379 float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1380 strout (pigbuf
, -1, -1, printcharfun
);
1386 print_string (obj
, printcharfun
);
1389 register EMACS_INT i_byte
;
1390 struct gcpro gcpro1
;
1392 EMACS_INT size_byte
;
1393 /* 1 means we must ensure that the next character we output
1394 cannot be taken as part of a hex character escape. */
1395 int need_nonhex
= 0;
1396 int multibyte
= STRING_MULTIBYTE (obj
);
1400 if (! EQ (Vprint_charset_text_property
, Qt
))
1401 obj
= print_prune_string_charset (obj
);
1403 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1411 size_byte
= SBYTES (obj
);
1413 for (i_byte
= 0; i_byte
< size_byte
;)
1415 /* Here, we must convert each multi-byte form to the
1416 corresponding character code before handing it to PRINTCHAR. */
1422 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
, len
);
1430 if (c
== '\n' && print_escape_newlines
)
1435 else if (c
== '\f' && print_escape_newlines
)
1441 && (CHAR_BYTE8_P (c
)
1442 || (! ASCII_CHAR_P (c
) && print_escape_multibyte
)))
1444 /* When multibyte is disabled,
1445 print multibyte string chars using hex escapes.
1446 For a char code that could be in a unibyte string,
1447 when found in a multibyte string, always use a hex escape
1448 so it reads back as multibyte. */
1451 if (CHAR_BYTE8_P (c
))
1452 sprintf (outbuf
, "\\%03o", CHAR_TO_BYTE8 (c
));
1455 sprintf (outbuf
, "\\x%04x", c
);
1458 strout (outbuf
, -1, -1, printcharfun
);
1460 else if (! multibyte
1461 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1462 && print_escape_nonascii
)
1464 /* When printing in a multibyte buffer
1465 or when explicitly requested,
1466 print single-byte non-ASCII string chars
1467 using octal escapes. */
1469 sprintf (outbuf
, "\\%03o", c
);
1470 strout (outbuf
, -1, -1, printcharfun
);
1474 /* If we just had a hex escape, and this character
1475 could be taken as part of it,
1476 output `\ ' to prevent that. */
1480 if ((c
>= 'a' && c
<= 'f')
1481 || (c
>= 'A' && c
<= 'F')
1482 || (c
>= '0' && c
<= '9'))
1483 strout ("\\ ", -1, -1, printcharfun
);
1486 if (c
== '\"' || c
== '\\')
1493 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1495 traverse_intervals (STRING_INTERVALS (obj
),
1496 0, print_interval
, printcharfun
);
1506 register int confusing
;
1507 register unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1508 register unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1511 EMACS_INT size_byte
;
1514 name
= SYMBOL_NAME (obj
);
1516 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1519 /* If symbol name begins with a digit, and ends with a digit,
1520 and contains nothing but digits and `e', it could be treated
1521 as a number. So set CONFUSING.
1523 Symbols that contain periods could also be taken as numbers,
1524 but periods are always escaped, so we don't have to worry
1526 else if (*p
>= '0' && *p
<= '9'
1527 && end
[-1] >= '0' && end
[-1] <= '9')
1529 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1530 /* Needed for \2e10. */
1531 || *p
== 'e' || *p
== 'E'))
1533 confusing
= (end
== p
);
1538 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1544 size_byte
= SBYTES (name
);
1546 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1548 /* Here, we must convert each multi-byte form to the
1549 corresponding character code before handing it to PRINTCHAR. */
1550 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1555 if (c
== '\"' || c
== '\\' || c
== '\''
1556 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1557 || c
== ',' || c
=='.' || c
== '`'
1558 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1560 PRINTCHAR ('\\'), confusing
= 0;
1568 /* If deeper than spec'd depth, print placeholder. */
1569 if (INTEGERP (Vprint_level
)
1570 && print_depth
> XINT (Vprint_level
))
1571 strout ("...", -1, -1, printcharfun
);
1572 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1573 && (EQ (XCAR (obj
), Qquote
)))
1576 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1578 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1579 && (EQ (XCAR (obj
), Qfunction
)))
1583 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1585 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1586 && ((EQ (XCAR (obj
), Qbackquote
))))
1588 print_object (XCAR (obj
), printcharfun
, 0);
1589 new_backquote_output
++;
1590 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1591 new_backquote_output
--;
1593 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1594 && new_backquote_output
1595 && ((EQ (XCAR (obj
), Qbackquote
)
1596 || EQ (XCAR (obj
), Qcomma
)
1597 || EQ (XCAR (obj
), Qcomma_at
)
1598 || EQ (XCAR (obj
), Qcomma_dot
))))
1600 print_object (XCAR (obj
), printcharfun
, 0);
1601 new_backquote_output
--;
1602 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1603 new_backquote_output
++;
1610 EMACS_INT print_length
;
1612 Lisp_Object halftail
= obj
;
1614 /* Negative values of print-length are invalid in CL.
1615 Treat them like nil, as CMUCL does. */
1616 if (NATNUMP (Vprint_length
))
1617 print_length
= XFASTINT (Vprint_length
);
1624 /* Detect circular list. */
1625 if (NILP (Vprint_circle
))
1627 /* Simple but imcomplete way. */
1628 if (i
!= 0 && EQ (obj
, halftail
))
1630 sprintf (buf
, " . #%d", i
/ 2);
1631 strout (buf
, -1, -1, printcharfun
);
1637 /* With the print-circle feature. */
1640 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1643 strout (" . ", 3, 3, printcharfun
);
1644 print_object (obj
, printcharfun
, escapeflag
);
1653 if (print_length
&& i
> print_length
)
1655 strout ("...", 3, 3, printcharfun
);
1659 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1663 halftail
= XCDR (halftail
);
1667 /* OBJ non-nil here means it's the end of a dotted list. */
1670 strout (" . ", 3, 3, printcharfun
);
1671 print_object (obj
, printcharfun
, escapeflag
);
1679 case Lisp_Vectorlike
:
1684 strout ("#<process ", -1, -1, printcharfun
);
1685 print_string (XPROCESS (obj
)->name
, printcharfun
);
1689 print_string (XPROCESS (obj
)->name
, printcharfun
);
1691 else if (BOOL_VECTOR_P (obj
))
1694 register unsigned char c
;
1695 struct gcpro gcpro1
;
1696 EMACS_INT size_in_chars
1697 = ((XBOOL_VECTOR (obj
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
1698 / BOOL_VECTOR_BITS_PER_CHAR
);
1704 sprintf (buf
, "%ld", (long) XBOOL_VECTOR (obj
)->size
);
1705 strout (buf
, -1, -1, printcharfun
);
1708 /* Don't print more characters than the specified maximum.
1709 Negative values of print-length are invalid. Treat them
1710 like a print-length of nil. */
1711 if (NATNUMP (Vprint_length
)
1712 && XFASTINT (Vprint_length
) < size_in_chars
)
1713 size_in_chars
= XFASTINT (Vprint_length
);
1715 for (i
= 0; i
< size_in_chars
; i
++)
1718 c
= XBOOL_VECTOR (obj
)->data
[i
];
1719 if (c
== '\n' && print_escape_newlines
)
1724 else if (c
== '\f' && print_escape_newlines
)
1729 else if (c
> '\177')
1731 /* Use octal escapes to avoid encoding issues. */
1733 PRINTCHAR ('0' + ((c
>> 6) & 3));
1734 PRINTCHAR ('0' + ((c
>> 3) & 7));
1735 PRINTCHAR ('0' + (c
& 7));
1739 if (c
== '\"' || c
== '\\')
1748 else if (SUBRP (obj
))
1750 strout ("#<subr ", -1, -1, printcharfun
);
1751 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
);
1754 else if (WINDOWP (obj
))
1756 strout ("#<window ", -1, -1, printcharfun
);
1757 sprintf (buf
, "%ld", (long) XFASTINT (XWINDOW (obj
)->sequence_number
));
1758 strout (buf
, -1, -1, printcharfun
);
1759 if (!NILP (XWINDOW (obj
)->buffer
))
1761 strout (" on ", -1, -1, printcharfun
);
1762 print_string (BVAR (XBUFFER (XWINDOW (obj
)->buffer
), name
), printcharfun
);
1766 else if (TERMINALP (obj
))
1768 struct terminal
*t
= XTERMINAL (obj
);
1769 strout ("#<terminal ", -1, -1, printcharfun
);
1770 sprintf (buf
, "%d", t
->id
);
1771 strout (buf
, -1, -1, printcharfun
);
1774 strout (" on ", -1, -1, printcharfun
);
1775 strout (t
->name
, -1, -1, printcharfun
);
1779 else if (HASH_TABLE_P (obj
))
1781 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1783 EMACS_INT real_size
, size
;
1785 strout ("#<hash-table", -1, -1, printcharfun
);
1786 if (SYMBOLP (h
->test
))
1790 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
);
1792 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
);
1794 sprintf (buf
, "%ld/%ld", (long) h
->count
,
1795 (long) XVECTOR (h
->next
)->size
);
1796 strout (buf
, -1, -1, printcharfun
);
1798 sprintf (buf
, " 0x%lx", (unsigned long) h
);
1799 strout (buf
, -1, -1, printcharfun
);
1802 /* Implement a readable output, e.g.:
1803 #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
1804 /* Always print the size. */
1805 sprintf (buf
, "#s(hash-table size %ld",
1806 (long) XVECTOR (h
->next
)->size
);
1807 strout (buf
, -1, -1, printcharfun
);
1809 if (!NILP (h
->test
))
1811 strout (" test ", -1, -1, printcharfun
);
1812 print_object (h
->test
, printcharfun
, escapeflag
);
1815 if (!NILP (h
->weak
))
1817 strout (" weakness ", -1, -1, printcharfun
);
1818 print_object (h
->weak
, printcharfun
, escapeflag
);
1821 if (!NILP (h
->rehash_size
))
1823 strout (" rehash-size ", -1, -1, printcharfun
);
1824 print_object (h
->rehash_size
, printcharfun
, escapeflag
);
1827 if (!NILP (h
->rehash_threshold
))
1829 strout (" rehash-threshold ", -1, -1, printcharfun
);
1830 print_object (h
->rehash_threshold
, printcharfun
, escapeflag
);
1833 strout (" data ", -1, -1, printcharfun
);
1835 /* Print the data here as a plist. */
1836 real_size
= HASH_TABLE_SIZE (h
);
1839 /* Don't print more elements than the specified maximum. */
1840 if (NATNUMP (Vprint_length
)
1841 && XFASTINT (Vprint_length
) < size
)
1842 size
= XFASTINT (Vprint_length
);
1845 for (i
= 0; i
< size
; i
++)
1846 if (!NILP (HASH_HASH (h
, i
)))
1848 if (i
) PRINTCHAR (' ');
1849 print_object (HASH_KEY (h
, i
), printcharfun
, escapeflag
);
1851 print_object (HASH_VALUE (h
, i
), printcharfun
, escapeflag
);
1854 if (size
< real_size
)
1855 strout (" ...", 4, 4, printcharfun
);
1861 else if (BUFFERP (obj
))
1863 if (NILP (BVAR (XBUFFER (obj
), name
)))
1864 strout ("#<killed buffer>", -1, -1, printcharfun
);
1865 else if (escapeflag
)
1867 strout ("#<buffer ", -1, -1, printcharfun
);
1868 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1872 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1874 else if (WINDOW_CONFIGURATIONP (obj
))
1876 strout ("#<window-configuration>", -1, -1, printcharfun
);
1878 else if (FRAMEP (obj
))
1880 strout ((FRAME_LIVE_P (XFRAME (obj
))
1881 ? "#<frame " : "#<dead frame "),
1882 -1, -1, printcharfun
);
1883 print_string (XFRAME (obj
)->name
, printcharfun
);
1884 sprintf (buf
, " 0x%lx", (unsigned long) (XFRAME (obj
)));
1885 strout (buf
, -1, -1, printcharfun
);
1888 else if (FONTP (obj
))
1892 if (! FONT_OBJECT_P (obj
))
1894 if (FONT_SPEC_P (obj
))
1895 strout ("#<font-spec", -1, -1, printcharfun
);
1897 strout ("#<font-entity", -1, -1, printcharfun
);
1898 for (i
= 0; i
< FONT_SPEC_MAX
; i
++)
1901 if (i
< FONT_WEIGHT_INDEX
|| i
> FONT_WIDTH_INDEX
)
1902 print_object (AREF (obj
, i
), printcharfun
, escapeflag
);
1904 print_object (font_style_symbolic (obj
, i
, 0),
1905 printcharfun
, escapeflag
);
1910 strout ("#<font-object ", -1, -1, printcharfun
);
1911 print_object (AREF (obj
, FONT_NAME_INDEX
), printcharfun
,
1918 EMACS_INT size
= XVECTOR (obj
)->size
;
1919 if (COMPILEDP (obj
))
1922 size
&= PSEUDOVECTOR_SIZE_MASK
;
1924 if (CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
))
1926 /* We print a char-table as if it were a vector,
1927 lumping the parent and default slots in with the
1928 character slots. But we add #^ as a prefix. */
1930 /* Make each lowest sub_char_table start a new line.
1931 Otherwise we'll make a line extremely long, which
1932 results in slow redisplay. */
1933 if (SUB_CHAR_TABLE_P (obj
)
1934 && XINT (XSUB_CHAR_TABLE (obj
)->depth
) == 3)
1938 if (SUB_CHAR_TABLE_P (obj
))
1940 size
&= PSEUDOVECTOR_SIZE_MASK
;
1942 if (size
& PSEUDOVECTOR_FLAG
)
1948 register Lisp_Object tem
;
1949 EMACS_INT real_size
= size
;
1951 /* Don't print more elements than the specified maximum. */
1952 if (NATNUMP (Vprint_length
)
1953 && XFASTINT (Vprint_length
) < size
)
1954 size
= XFASTINT (Vprint_length
);
1956 for (i
= 0; i
< size
; i
++)
1958 if (i
) PRINTCHAR (' ');
1959 tem
= XVECTOR (obj
)->contents
[i
];
1960 print_object (tem
, printcharfun
, escapeflag
);
1962 if (size
< real_size
)
1963 strout (" ...", 4, 4, printcharfun
);
1970 switch (XMISCTYPE (obj
))
1972 case Lisp_Misc_Marker
:
1973 strout ("#<marker ", -1, -1, printcharfun
);
1974 /* Do you think this is necessary? */
1975 if (XMARKER (obj
)->insertion_type
!= 0)
1976 strout ("(moves after insertion) ", -1, -1, printcharfun
);
1977 if (! XMARKER (obj
)->buffer
)
1978 strout ("in no buffer", -1, -1, printcharfun
);
1981 sprintf (buf
, "at %ld", (long)marker_position (obj
));
1982 strout (buf
, -1, -1, printcharfun
);
1983 strout (" in ", -1, -1, printcharfun
);
1984 print_string (BVAR (XMARKER (obj
)->buffer
, name
), printcharfun
);
1989 case Lisp_Misc_Overlay
:
1990 strout ("#<overlay ", -1, -1, printcharfun
);
1991 if (! XMARKER (OVERLAY_START (obj
))->buffer
)
1992 strout ("in no buffer", -1, -1, printcharfun
);
1995 sprintf (buf
, "from %ld to %ld in ",
1996 (long)marker_position (OVERLAY_START (obj
)),
1997 (long)marker_position (OVERLAY_END (obj
)));
1998 strout (buf
, -1, -1, printcharfun
);
1999 print_string (BVAR (XMARKER (OVERLAY_START (obj
))->buffer
, name
),
2005 /* Remaining cases shouldn't happen in normal usage, but let's print
2006 them anyway for the benefit of the debugger. */
2007 case Lisp_Misc_Free
:
2008 strout ("#<misc free cell>", -1, -1, printcharfun
);
2011 case Lisp_Misc_Save_Value
:
2012 strout ("#<save_value ", -1, -1, printcharfun
);
2013 sprintf(buf
, "ptr=0x%08lx int=%d",
2014 (unsigned long) XSAVE_VALUE (obj
)->pointer
,
2015 XSAVE_VALUE (obj
)->integer
);
2016 strout (buf
, -1, -1, printcharfun
);
2028 /* We're in trouble if this happens!
2029 Probably should just abort () */
2030 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
);
2032 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2033 else if (VECTORLIKEP (obj
))
2034 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
2036 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2037 strout (buf
, -1, -1, printcharfun
);
2038 strout (" Save your buffers immediately and please report this bug>",
2039 -1, -1, printcharfun
);
2047 /* Print a description of INTERVAL using PRINTCHARFUN.
2048 This is part of printing a string that has text properties. */
2051 print_interval (INTERVAL interval
, Lisp_Object printcharfun
)
2053 if (NILP (interval
->plist
))
2056 print_object (make_number (interval
->position
), printcharfun
, 1);
2058 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2061 print_object (interval
->plist
, printcharfun
, 1);
2066 syms_of_print (void)
2068 Qtemp_buffer_setup_hook
= intern_c_string ("temp-buffer-setup-hook");
2069 staticpro (&Qtemp_buffer_setup_hook
);
2071 DEFVAR_LISP ("standard-output", Vstandard_output
,
2072 doc
: /* Output stream `print' uses by default for outputting a character.
2073 This may be any function of one argument.
2074 It may also be a buffer (output is inserted before point)
2075 or a marker (output is inserted and the marker is advanced)
2076 or the symbol t (output appears in the echo area). */);
2077 Vstandard_output
= Qt
;
2078 Qstandard_output
= intern_c_string ("standard-output");
2079 staticpro (&Qstandard_output
);
2081 DEFVAR_LISP ("float-output-format", Vfloat_output_format
,
2082 doc
: /* The format descriptor string used to print floats.
2083 This is a %-spec like those accepted by `printf' in C,
2084 but with some restrictions. It must start with the two characters `%.'.
2085 After that comes an integer precision specification,
2086 and then a letter which controls the format.
2087 The letters allowed are `e', `f' and `g'.
2088 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2089 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2090 Use `g' to choose the shorter of those two formats for the number at hand.
2091 The precision in any of these cases is the number of digits following
2092 the decimal point. With `f', a precision of 0 means to omit the
2093 decimal point. 0 is not allowed with `e' or `g'.
2095 A value of nil means to use the shortest notation
2096 that represents the number without losing information. */);
2097 Vfloat_output_format
= Qnil
;
2098 Qfloat_output_format
= intern_c_string ("float-output-format");
2099 staticpro (&Qfloat_output_format
);
2101 DEFVAR_LISP ("print-length", Vprint_length
,
2102 doc
: /* Maximum length of list to print before abbreviating.
2103 A value of nil means no limit. See also `eval-expression-print-length'. */);
2104 Vprint_length
= Qnil
;
2106 DEFVAR_LISP ("print-level", Vprint_level
,
2107 doc
: /* Maximum depth of list nesting to print before abbreviating.
2108 A value of nil means no limit. See also `eval-expression-print-level'. */);
2109 Vprint_level
= Qnil
;
2111 DEFVAR_BOOL ("print-escape-newlines", print_escape_newlines
,
2112 doc
: /* Non-nil means print newlines in strings as `\\n'.
2113 Also print formfeeds as `\\f'. */);
2114 print_escape_newlines
= 0;
2116 DEFVAR_BOOL ("print-escape-nonascii", print_escape_nonascii
,
2117 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2118 \(OOO is the octal representation of the character code.)
2119 Only single-byte characters are affected, and only in `prin1'.
2120 When the output goes in a multibyte buffer, this feature is
2121 enabled regardless of the value of the variable. */);
2122 print_escape_nonascii
= 0;
2124 DEFVAR_BOOL ("print-escape-multibyte", print_escape_multibyte
,
2125 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2126 \(XXXX is the hex representation of the character code.)
2127 This affects only `prin1'. */);
2128 print_escape_multibyte
= 0;
2130 DEFVAR_BOOL ("print-quoted", print_quoted
,
2131 doc
: /* Non-nil means print quoted forms with reader syntax.
2132 I.e., (quote foo) prints as 'foo, (function foo) as #'foo. */);
2135 DEFVAR_LISP ("print-gensym", Vprint_gensym
,
2136 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2137 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2138 When the uninterned symbol appears within a recursive data structure,
2139 and the symbol appears more than once, in addition use the #N# and #N=
2140 constructs as needed, so that multiple references to the same symbol are
2141 shared once again when the text is read back. */);
2142 Vprint_gensym
= Qnil
;
2144 DEFVAR_LISP ("print-circle", Vprint_circle
,
2145 doc
: /* *Non-nil means print recursive structures using #N= and #N# syntax.
2146 If nil, printing proceeds recursively and may lead to
2147 `max-lisp-eval-depth' being exceeded or an error may occur:
2148 \"Apparently circular structure being printed.\" Also see
2149 `print-length' and `print-level'.
2150 If non-nil, shared substructures anywhere in the structure are printed
2151 with `#N=' before the first occurrence (in the order of the print
2152 representation) and `#N#' in place of each subsequent occurrence,
2153 where N is a positive decimal integer. */);
2154 Vprint_circle
= Qnil
;
2156 DEFVAR_LISP ("print-continuous-numbering", Vprint_continuous_numbering
,
2157 doc
: /* *Non-nil means number continuously across print calls.
2158 This affects the numbers printed for #N= labels and #M# references.
2159 See also `print-circle', `print-gensym', and `print-number-table'.
2160 This variable should not be set with `setq'; bind it with a `let' instead. */);
2161 Vprint_continuous_numbering
= Qnil
;
2163 DEFVAR_LISP ("print-number-table", Vprint_number_table
,
2164 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2165 The Lisp printer uses this vector to detect Lisp objects referenced more
2168 When you bind `print-continuous-numbering' to t, you should probably
2169 also bind `print-number-table' to nil. This ensures that the value of
2170 `print-number-table' can be garbage-collected once the printing is
2171 done. If all elements of `print-number-table' are nil, it means that
2172 the printing done so far has not found any shared structure or objects
2173 that need to be recorded in the table. */);
2174 Vprint_number_table
= Qnil
;
2176 DEFVAR_LISP ("print-charset-text-property", Vprint_charset_text_property
,
2177 doc
: /* A flag to control printing of `charset' text property on printing a string.
2178 The value must be nil, t, or `default'.
2180 If the value is nil, don't print the text property `charset'.
2182 If the value is t, always print the text property `charset'.
2184 If the value is `default', print the text property `charset' only when
2185 the value is different from what is guessed in the current charset
2187 Vprint_charset_text_property
= Qdefault
;
2189 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2190 staticpro (&Vprin1_to_string_buffer
);
2193 defsubr (&Sprin1_to_string
);
2194 defsubr (&Serror_message_string
);
2198 defsubr (&Swrite_char
);
2199 defsubr (&Sexternal_debugging_output
);
2200 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2201 defsubr (&Sredirect_debugging_output
);
2204 Qexternal_debugging_output
= intern_c_string ("external-debugging-output");
2205 staticpro (&Qexternal_debugging_output
);
2207 Qprint_escape_newlines
= intern_c_string ("print-escape-newlines");
2208 staticpro (&Qprint_escape_newlines
);
2210 Qprint_escape_multibyte
= intern_c_string ("print-escape-multibyte");
2211 staticpro (&Qprint_escape_multibyte
);
2213 Qprint_escape_nonascii
= intern_c_string ("print-escape-nonascii");
2214 staticpro (&Qprint_escape_nonascii
);
2216 print_prune_charset_plist
= Qnil
;
2217 staticpro (&print_prune_charset_plist
);