1 /* Lisp object printing and output streams.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2012
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
;
52 /* Default to values appropriate for IEEE floating point. */
57 /* Avoid actual stack overflow in print. */
58 static ptrdiff_t print_depth
;
60 /* Level of nesting inside outputting backquote in new style. */
61 static ptrdiff_t new_backquote_output
;
63 /* Detect most circularities to print finite output. */
64 #define PRINT_CIRCLE 200
65 static Lisp_Object being_printed
[PRINT_CIRCLE
];
67 /* When printing into a buffer, first we put the text in this
68 block, then insert it all at once. */
69 static char *print_buffer
;
71 /* Size allocated in print_buffer. */
72 static ptrdiff_t print_buffer_size
;
73 /* Chars stored in print_buffer. */
74 static ptrdiff_t print_buffer_pos
;
75 /* Bytes stored in print_buffer. */
76 static ptrdiff_t print_buffer_pos_byte
;
78 Lisp_Object Qprint_escape_newlines
;
79 static Lisp_Object Qprint_escape_multibyte
, Qprint_escape_nonascii
;
81 /* Vprint_number_table is a table, that keeps objects that are going to
82 be printed, to allow use of #n= and #n# to express sharing.
83 For any given object, the table can give the following values:
84 t the object will be printed only once.
85 -N the object will be printed several times and will take number N.
86 N the object has been printed so we can refer to it as #N#.
87 print_number_index holds the largest N already used.
88 N has to be striclty larger than 0 since we need to distinguish -N. */
89 static ptrdiff_t print_number_index
;
90 static void print_interval (INTERVAL interval
, Lisp_Object printcharfun
);
92 /* GDB resets this to zero on W32 to disable OutputDebugString calls. */
93 int print_output_debug_flag EXTERNALLY_VISIBLE
= 1;
96 /* Low level output routines for characters and strings. */
98 /* Lisp functions to do output using a stream
99 must have the stream in a variable called printcharfun
100 and must start with PRINTPREPARE, end with PRINTFINISH,
101 and use PRINTDECLARE to declare common variables.
102 Use PRINTCHAR to output one character,
103 or call strout to output a block of characters. */
105 #define PRINTDECLARE \
106 struct buffer *old = current_buffer; \
107 ptrdiff_t old_point = -1, start_point = -1; \
108 ptrdiff_t old_point_byte = -1, start_point_byte = -1; \
109 ptrdiff_t specpdl_count = SPECPDL_INDEX (); \
110 int free_print_buffer = 0; \
111 int multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters)); \
114 #define PRINTPREPARE \
115 original = printcharfun; \
116 if (NILP (printcharfun)) printcharfun = Qt; \
117 if (BUFFERP (printcharfun)) \
119 if (XBUFFER (printcharfun) != current_buffer) \
120 Fset_buffer (printcharfun); \
121 printcharfun = Qnil; \
123 if (MARKERP (printcharfun)) \
125 ptrdiff_t marker_pos; \
126 if (! XMARKER (printcharfun)->buffer) \
127 error ("Marker does not point anywhere"); \
128 if (XMARKER (printcharfun)->buffer != current_buffer) \
129 set_buffer_internal (XMARKER (printcharfun)->buffer); \
130 marker_pos = marker_position (printcharfun); \
131 if (marker_pos < BEGV || marker_pos > ZV) \
132 error ("Marker is outside the accessible part of the buffer"); \
134 old_point_byte = PT_BYTE; \
135 SET_PT_BOTH (marker_pos, \
136 marker_byte_position (printcharfun)); \
138 start_point_byte = PT_BYTE; \
139 printcharfun = Qnil; \
141 if (NILP (printcharfun)) \
143 Lisp_Object string; \
144 if (NILP (BVAR (current_buffer, enable_multibyte_characters)) \
145 && ! print_escape_multibyte) \
146 specbind (Qprint_escape_multibyte, Qt); \
147 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)) \
148 && ! print_escape_nonascii) \
149 specbind (Qprint_escape_nonascii, Qt); \
150 if (print_buffer != 0) \
152 string = make_string_from_bytes (print_buffer, \
154 print_buffer_pos_byte); \
155 record_unwind_protect (print_unwind, string); \
159 int new_size = 1000; \
160 print_buffer = (char *) xmalloc (new_size); \
161 print_buffer_size = new_size; \
162 free_print_buffer = 1; \
164 print_buffer_pos = 0; \
165 print_buffer_pos_byte = 0; \
167 if (EQ (printcharfun, Qt) && ! noninteractive) \
168 setup_echo_area_for_printing (multibyte);
170 #define PRINTFINISH \
171 if (NILP (printcharfun)) \
173 if (print_buffer_pos != print_buffer_pos_byte \
174 && NILP (BVAR (current_buffer, enable_multibyte_characters))) \
176 unsigned char *temp \
177 = (unsigned char *) alloca (print_buffer_pos + 1); \
178 copy_text ((unsigned char *) print_buffer, temp, \
179 print_buffer_pos_byte, 1, 0); \
180 insert_1_both ((char *) temp, print_buffer_pos, \
181 print_buffer_pos, 0, 1, 0); \
184 insert_1_both (print_buffer, print_buffer_pos, \
185 print_buffer_pos_byte, 0, 1, 0); \
186 signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
188 if (free_print_buffer) \
190 xfree (print_buffer); \
193 unbind_to (specpdl_count, Qnil); \
194 if (MARKERP (original)) \
195 set_marker_both (original, Qnil, PT, PT_BYTE); \
196 if (old_point >= 0) \
197 SET_PT_BOTH (old_point + (old_point >= start_point \
198 ? PT - start_point : 0), \
199 old_point_byte + (old_point_byte >= start_point_byte \
200 ? PT_BYTE - start_point_byte : 0)); \
201 if (old != current_buffer) \
202 set_buffer_internal (old);
204 #define PRINTCHAR(ch) printchar (ch, printcharfun)
206 /* This is used to restore the saved contents of print_buffer
207 when there is a recursive call to print. */
210 print_unwind (Lisp_Object saved_text
)
212 memcpy (print_buffer
, SDATA (saved_text
), SCHARS (saved_text
));
217 /* Print character CH using method FUN. FUN nil means print to
218 print_buffer. FUN t means print to echo area or stdout if
219 non-interactive. If FUN is neither nil nor t, call FUN with CH as
223 printchar (unsigned int ch
, Lisp_Object fun
)
225 if (!NILP (fun
) && !EQ (fun
, Qt
))
226 call1 (fun
, make_number (ch
));
229 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
230 int len
= CHAR_STRING (ch
, str
);
236 ptrdiff_t incr
= len
- (print_buffer_size
- print_buffer_pos_byte
);
239 xpalloc (print_buffer
, &print_buffer_size
, incr
, -1, 1);
240 memcpy (print_buffer
+ print_buffer_pos_byte
, str
, len
);
241 print_buffer_pos
+= 1;
242 print_buffer_pos_byte
+= len
;
244 else if (noninteractive
)
246 fwrite (str
, 1, len
, stdout
);
247 noninteractive_need_newline
= 1;
252 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
254 setup_echo_area_for_printing (multibyte_p
);
256 message_dolog ((char *) str
, len
, 0, multibyte_p
);
262 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
263 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
264 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
265 print_buffer. PRINTCHARFUN t means output to the echo area or to
266 stdout if non-interactive. If neither nil nor t, call Lisp
267 function PRINTCHARFUN for each character printed. MULTIBYTE
268 non-zero means PTR contains multibyte characters.
270 In the case where PRINTCHARFUN is nil, it is safe for PTR to point
271 to data in a Lisp string. Otherwise that is not safe. */
274 strout (const char *ptr
, ptrdiff_t size
, ptrdiff_t size_byte
,
275 Lisp_Object printcharfun
)
278 size_byte
= size
= strlen (ptr
);
280 if (NILP (printcharfun
))
282 ptrdiff_t incr
= size_byte
- (print_buffer_size
- print_buffer_pos_byte
);
284 print_buffer
= xpalloc (print_buffer
, &print_buffer_size
, incr
, -1, 1);
285 memcpy (print_buffer
+ print_buffer_pos_byte
, ptr
, size_byte
);
286 print_buffer_pos
+= size
;
287 print_buffer_pos_byte
+= size_byte
;
289 else if (noninteractive
&& EQ (printcharfun
, Qt
))
291 fwrite (ptr
, 1, size_byte
, stdout
);
292 noninteractive_need_newline
= 1;
294 else if (EQ (printcharfun
, Qt
))
296 /* Output to echo area. We're trying to avoid a little overhead
297 here, that's the reason we don't call printchar to do the
301 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
303 setup_echo_area_for_printing (multibyte_p
);
304 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
306 if (size
== size_byte
)
308 for (i
= 0; i
< size
; ++i
)
309 insert_char ((unsigned char) *ptr
++);
314 for (i
= 0; i
< size_byte
; i
+= len
)
316 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
324 /* PRINTCHARFUN is a Lisp function. */
327 if (size
== size_byte
)
329 while (i
< size_byte
)
337 while (i
< size_byte
)
339 /* Here, we must convert each multi-byte form to the
340 corresponding character code before handing it to
343 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
352 /* Print the contents of a string STRING using PRINTCHARFUN.
353 It isn't safe to use strout in many cases,
354 because printing one char can relocate. */
357 print_string (Lisp_Object string
, Lisp_Object printcharfun
)
359 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
363 if (print_escape_nonascii
)
364 string
= string_escape_byte8 (string
);
366 if (STRING_MULTIBYTE (string
))
367 chars
= SCHARS (string
);
368 else if (! print_escape_nonascii
369 && (EQ (printcharfun
, Qt
)
370 ? ! NILP (BVAR (&buffer_defaults
, enable_multibyte_characters
))
371 : ! NILP (BVAR (current_buffer
, enable_multibyte_characters
))))
373 /* If unibyte string STRING contains 8-bit codes, we must
374 convert STRING to a multibyte string containing the same
379 chars
= SBYTES (string
);
380 bytes
= count_size_as_multibyte (SDATA (string
), chars
);
383 newstr
= make_uninit_multibyte_string (chars
, bytes
);
384 memcpy (SDATA (newstr
), SDATA (string
), chars
);
385 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
390 chars
= SBYTES (string
);
392 if (EQ (printcharfun
, Qt
))
394 /* Output to echo area. */
395 ptrdiff_t nbytes
= SBYTES (string
);
398 /* Copy the string contents so that relocation of STRING by
399 GC does not cause trouble. */
402 SAFE_ALLOCA (buffer
, char *, nbytes
);
403 memcpy (buffer
, SDATA (string
), nbytes
);
405 strout (buffer
, chars
, SBYTES (string
), printcharfun
);
410 /* No need to copy, since output to print_buffer can't GC. */
411 strout (SSDATA (string
), chars
, SBYTES (string
), printcharfun
);
415 /* Otherwise, string may be relocated by printing one char.
416 So re-fetch the string address for each character. */
418 ptrdiff_t size
= SCHARS (string
);
419 ptrdiff_t size_byte
= SBYTES (string
);
422 if (size
== size_byte
)
423 for (i
= 0; i
< size
; i
++)
424 PRINTCHAR (SREF (string
, i
));
426 for (i
= 0; i
< size_byte
; )
428 /* Here, we must convert each multi-byte form to the
429 corresponding character code before handing it to PRINTCHAR. */
431 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
, len
);
439 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
440 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
441 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
442 (Lisp_Object character
, Lisp_Object printcharfun
)
446 if (NILP (printcharfun
))
447 printcharfun
= Vstandard_output
;
448 CHECK_NUMBER (character
);
450 PRINTCHAR (XINT (character
));
455 /* Used from outside of print.c to print a block of SIZE
456 single-byte chars at DATA on the default output stream.
457 Do not use this on the contents of a Lisp string. */
460 write_string (const char *data
, int size
)
463 Lisp_Object printcharfun
;
465 printcharfun
= Vstandard_output
;
468 strout (data
, size
, size
, printcharfun
);
472 /* Used to print a block of SIZE single-byte chars at DATA on a
473 specified stream PRINTCHARFUN.
474 Do not use this on the contents of a Lisp string. */
477 write_string_1 (const char *data
, int size
, Lisp_Object printcharfun
)
482 strout (data
, size
, size
, printcharfun
);
488 temp_output_buffer_setup (const char *bufname
)
490 ptrdiff_t count
= SPECPDL_INDEX ();
491 register struct buffer
*old
= current_buffer
;
492 register Lisp_Object buf
;
494 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
496 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
498 Fkill_all_local_variables ();
499 delete_all_overlays (current_buffer
);
500 BVAR (current_buffer
, directory
) = BVAR (old
, directory
);
501 BVAR (current_buffer
, read_only
) = Qnil
;
502 BVAR (current_buffer
, filename
) = Qnil
;
503 BVAR (current_buffer
, undo_list
) = Qt
;
504 eassert (current_buffer
->overlays_before
== NULL
);
505 eassert (current_buffer
->overlays_after
== NULL
);
506 BVAR (current_buffer
, enable_multibyte_characters
)
507 = BVAR (&buffer_defaults
, enable_multibyte_characters
);
508 specbind (Qinhibit_read_only
, Qt
);
509 specbind (Qinhibit_modification_hooks
, Qt
);
511 XSETBUFFER (buf
, current_buffer
);
513 Frun_hooks (1, &Qtemp_buffer_setup_hook
);
515 unbind_to (count
, Qnil
);
517 specbind (Qstandard_output
, buf
);
520 static void print (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
);
521 static void print_preprocess (Lisp_Object obj
);
522 static void print_preprocess_string (INTERVAL interval
, Lisp_Object arg
);
523 static void print_object (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
);
525 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
526 doc
: /* Output a newline to stream PRINTCHARFUN.
527 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
528 (Lisp_Object printcharfun
)
532 if (NILP (printcharfun
))
533 printcharfun
= Vstandard_output
;
540 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
541 doc
: /* Output the printed representation of OBJECT, any Lisp object.
542 Quoting characters are printed when needed to make output that `read'
543 can handle, whenever this is possible. For complex objects, the behavior
544 is controlled by `print-level' and `print-length', which see.
546 OBJECT is any of the Lisp data types: a number, a string, a symbol,
547 a list, a buffer, a window, a frame, etc.
549 A printed representation of an object is text which describes that object.
551 Optional argument PRINTCHARFUN is the output stream, which can be one
554 - a buffer, in which case output is inserted into that buffer at point;
555 - a marker, in which case output is inserted at marker's position;
556 - a function, in which case that function is called once for each
557 character of OBJECT's printed representation;
558 - a symbol, in which case that symbol's function definition is called; or
559 - t, in which case the output is displayed in the echo area.
561 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
563 (Lisp_Object object
, Lisp_Object printcharfun
)
567 if (NILP (printcharfun
))
568 printcharfun
= Vstandard_output
;
570 print (object
, printcharfun
, 1);
575 /* a buffer which is used to hold output being built by prin1-to-string */
576 Lisp_Object Vprin1_to_string_buffer
;
578 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
579 doc
: /* Return a string containing the printed representation of OBJECT.
580 OBJECT can be any Lisp object. This function outputs quoting characters
581 when necessary to make output that `read' can handle, whenever possible,
582 unless the optional second argument NOESCAPE is non-nil. For complex objects,
583 the behavior is controlled by `print-level' and `print-length', which see.
585 OBJECT is any of the Lisp data types: a number, a string, a symbol,
586 a list, a buffer, a window, a frame, etc.
588 A printed representation of an object is text which describes that object. */)
589 (Lisp_Object object
, Lisp_Object noescape
)
591 Lisp_Object printcharfun
;
592 /* struct gcpro gcpro1, gcpro2; */
593 Lisp_Object save_deactivate_mark
;
594 ptrdiff_t count
= SPECPDL_INDEX ();
595 struct buffer
*previous
;
597 specbind (Qinhibit_modification_hooks
, Qt
);
602 /* Save and restore this--we are altering a buffer
603 but we don't want to deactivate the mark just for that.
604 No need for specbind, since errors deactivate the mark. */
605 save_deactivate_mark
= Vdeactivate_mark
;
606 /* GCPRO2 (object, save_deactivate_mark); */
609 printcharfun
= Vprin1_to_string_buffer
;
611 print (object
, printcharfun
, NILP (noescape
));
612 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINISH */
616 previous
= current_buffer
;
617 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
618 object
= Fbuffer_string ();
619 if (SBYTES (object
) == SCHARS (object
))
620 STRING_SET_UNIBYTE (object
);
622 /* Note that this won't make prepare_to_modify_buffer call
623 ask-user-about-supersession-threat because this buffer
624 does not visit a file. */
626 set_buffer_internal (previous
);
628 Vdeactivate_mark
= save_deactivate_mark
;
632 return unbind_to (count
, object
);
635 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
636 doc
: /* Output the printed representation of OBJECT, any Lisp object.
637 No quoting characters are used; no delimiters are printed around
638 the contents of strings.
640 OBJECT is any of the Lisp data types: a number, a string, a symbol,
641 a list, a buffer, a window, a frame, etc.
643 A printed representation of an object is text which describes that object.
645 Optional argument PRINTCHARFUN is the output stream, which can be one
648 - a buffer, in which case output is inserted into that buffer at point;
649 - a marker, in which case output is inserted at marker's position;
650 - a function, in which case that function is called once for each
651 character of OBJECT's printed representation;
652 - a symbol, in which case that symbol's function definition is called; or
653 - t, in which case the output is displayed in the echo area.
655 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
657 (Lisp_Object object
, Lisp_Object printcharfun
)
661 if (NILP (printcharfun
))
662 printcharfun
= Vstandard_output
;
664 print (object
, printcharfun
, 0);
669 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
670 doc
: /* Output the printed representation of OBJECT, with newlines around it.
671 Quoting characters are printed when needed to make output that `read'
672 can handle, whenever this is possible. For complex objects, the behavior
673 is controlled by `print-level' and `print-length', which see.
675 OBJECT is any of the Lisp data types: a number, a string, a symbol,
676 a list, a buffer, a window, a frame, etc.
678 A printed representation of an object is text which describes that object.
680 Optional argument PRINTCHARFUN is the output stream, which can be one
683 - a buffer, in which case output is inserted into that buffer at point;
684 - a marker, in which case output is inserted at marker's position;
685 - a function, in which case that function is called once for each
686 character of OBJECT's printed representation;
687 - a symbol, in which case that symbol's function definition is called; or
688 - t, in which case the output is displayed in the echo area.
690 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
692 (Lisp_Object object
, Lisp_Object printcharfun
)
697 if (NILP (printcharfun
))
698 printcharfun
= Vstandard_output
;
702 print (object
, printcharfun
, 1);
709 /* The subroutine object for external-debugging-output is kept here
710 for the convenience of the debugger. */
711 Lisp_Object Qexternal_debugging_output
;
713 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
714 doc
: /* Write CHARACTER to stderr.
715 You can call print while debugging emacs, and pass it this function
716 to make it write to the debugging output. */)
717 (Lisp_Object character
)
719 CHECK_NUMBER (character
);
720 putc (XINT (character
) & 0xFF, stderr
);
723 /* Send the output to a debugger (nothing happens if there isn't one). */
724 if (print_output_debug_flag
)
726 char buf
[2] = {(char) XINT (character
), '\0'};
727 OutputDebugString (buf
);
734 /* This function is never called. Its purpose is to prevent
735 print_output_debug_flag from being optimized away. */
737 extern void debug_output_compilation_hack (int) EXTERNALLY_VISIBLE
;
739 debug_output_compilation_hack (int x
)
741 print_output_debug_flag
= x
;
744 #if defined (GNU_LINUX)
746 /* This functionality is not vitally important in general, so we rely on
747 non-portable ability to use stderr as lvalue. */
749 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
751 static FILE *initial_stderr_stream
= NULL
;
753 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
755 "FDebug output file: \nP",
756 doc
: /* Redirect debugging output (stderr stream) to file FILE.
757 If FILE is nil, reset target to the initial stderr stream.
758 Optional arg APPEND non-nil (interactively, with prefix arg) means
759 append to existing target file. */)
760 (Lisp_Object file
, Lisp_Object append
)
762 if (initial_stderr_stream
!= NULL
)
768 stderr
= initial_stderr_stream
;
769 initial_stderr_stream
= NULL
;
773 file
= Fexpand_file_name (file
, Qnil
);
774 initial_stderr_stream
= stderr
;
775 stderr
= fopen (SSDATA (file
), NILP (append
) ? "w" : "a");
778 stderr
= initial_stderr_stream
;
779 initial_stderr_stream
= NULL
;
780 report_file_error ("Cannot open debugging output stream",
786 #endif /* GNU_LINUX */
789 /* This is the interface for debugging printing. */
792 debug_print (Lisp_Object arg
)
794 Fprin1 (arg
, Qexternal_debugging_output
);
795 fprintf (stderr
, "\r\n");
798 void safe_debug_print (Lisp_Object
) EXTERNALLY_VISIBLE
;
800 safe_debug_print (Lisp_Object arg
)
802 int valid
= valid_lisp_object_p (arg
);
807 fprintf (stderr
, "#<%s_LISP_OBJECT 0x%08"pI
"x>\r\n",
808 !valid
? "INVALID" : "SOME",
813 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
815 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
816 See Info anchor `(elisp)Definition of signal' for some details on how this
817 error message is constructed. */)
820 struct buffer
*old
= current_buffer
;
824 /* If OBJ is (error STRING), just return STRING.
825 That is not only faster, it also avoids the need to allocate
826 space here when the error is due to memory full. */
827 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
828 && CONSP (XCDR (obj
))
829 && STRINGP (XCAR (XCDR (obj
)))
830 && NILP (XCDR (XCDR (obj
))))
831 return XCAR (XCDR (obj
));
833 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
835 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
836 value
= Fbuffer_string ();
840 set_buffer_internal (old
);
846 /* Print an error message for the error DATA onto Lisp output stream
847 STREAM (suitable for the print functions).
848 CONTEXT is a C string describing the context of the error.
849 CALLER is the Lisp function inside which the error was signaled. */
852 print_error_message (Lisp_Object data
, Lisp_Object stream
, const char *context
,
855 Lisp_Object errname
, errmsg
, file_error
, tail
;
860 write_string_1 (context
, -1, stream
);
862 /* If we know from where the error was signaled, show it in
864 if (!NILP (caller
) && SYMBOLP (caller
))
866 Lisp_Object cname
= SYMBOL_NAME (caller
);
869 SAFE_ALLOCA (name
, char *, SBYTES (cname
));
870 memcpy (name
, SDATA (cname
), SBYTES (cname
));
871 message_dolog (name
, SBYTES (cname
), 0, 0);
872 message_dolog (": ", 2, 0, 0);
876 errname
= Fcar (data
);
878 if (EQ (errname
, Qerror
))
883 errmsg
= Fcar (data
);
888 Lisp_Object error_conditions
;
889 errmsg
= Fget (errname
, Qerror_message
);
890 error_conditions
= Fget (errname
, Qerror_conditions
);
891 file_error
= Fmemq (Qfile_error
, error_conditions
);
894 /* Print an error message including the data items. */
896 tail
= Fcdr_safe (data
);
899 /* For file-error, make error message by concatenating
900 all the data items. They are all strings. */
901 if (!NILP (file_error
) && CONSP (tail
))
902 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
904 if (STRINGP (errmsg
))
905 Fprinc (errmsg
, stream
);
907 write_string_1 ("peculiar error", -1, stream
);
909 for (i
= 0; CONSP (tail
); tail
= XCDR (tail
), i
= 1)
913 write_string_1 (i
? ", " : ": ", 2, stream
);
915 if (!NILP (file_error
) || EQ (errname
, Qend_of_file
))
916 Fprinc (obj
, stream
);
918 Fprin1 (obj
, stream
);
927 * The buffer should be at least as large as the max string size of the
928 * largest float, printed in the biggest notation. This is undoubtedly
929 * 20d float_output_format, with the negative of the C-constant "HUGE"
932 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
934 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
935 * case of -1e307 in 20d float_output_format. What is one to do (short of
936 * re-writing _doprnt to be more sane)?
938 * Given the above, the buffer must be least FLOAT_TO_STRING_BUFSIZE bytes.
942 float_to_string (char *buf
, double data
)
947 /* Check for plus infinity in a way that won't lose
948 if there is no plus infinity. */
949 if (data
== data
/ 2 && data
> 1.0)
951 strcpy (buf
, "1.0e+INF");
954 /* Likewise for minus infinity. */
955 if (data
== data
/ 2 && data
< -1.0)
957 strcpy (buf
, "-1.0e+INF");
960 /* Check for NaN in a way that won't fail if there are no NaNs. */
961 if (! (data
* 0.0 >= 0.0))
963 /* Prepend "-" if the NaN's sign bit is negative.
964 The sign bit of a double is the bit that is 1 in -0.0. */
966 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
968 u_minus_zero
.d
= - 0.0;
969 for (i
= 0; i
< sizeof (double); i
++)
970 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
976 strcpy (buf
, "0.0e+NaN");
980 if (NILP (Vfloat_output_format
)
981 || !STRINGP (Vfloat_output_format
))
984 /* Generate the fewest number of digits that represent the
985 floating point value without losing information. */
986 dtoastr (buf
, FLOAT_TO_STRING_BUFSIZE
- 2, 0, 0, data
);
987 /* The decimal point must be printed, or the byte compiler can
988 get confused (Bug#8033). */
993 /* Check that the spec we have is fully valid.
994 This means not only valid for printf,
995 but meant for floats, and reasonable. */
996 cp
= SSDATA (Vfloat_output_format
);
1005 /* Check the width specification. */
1007 if ('0' <= *cp
&& *cp
<= '9')
1012 width
= (width
* 10) + (*cp
++ - '0');
1013 if (DBL_DIG
< width
)
1016 while (*cp
>= '0' && *cp
<= '9');
1018 /* A precision of zero is valid only for %f. */
1019 if (width
== 0 && *cp
!= 'f')
1023 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1029 sprintf (buf
, SSDATA (Vfloat_output_format
), data
);
1032 /* Make sure there is a decimal point with digit after, or an
1033 exponent, so that the value is readable as a float. But don't do
1034 this with "%.0f"; it's valid for that not to produce a decimal
1035 point. Note that width can be 0 only for %.0f. */
1038 for (cp
= buf
; *cp
; cp
++)
1039 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1042 if (*cp
== '.' && cp
[1] == 0)
1058 print (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
)
1060 new_backquote_output
= 0;
1062 /* Reset print_number_index and Vprint_number_table only when
1063 the variable Vprint_continuous_numbering is nil. Otherwise,
1064 the values of these variables will be kept between several
1066 if (NILP (Vprint_continuous_numbering
)
1067 || NILP (Vprint_number_table
))
1069 print_number_index
= 0;
1070 Vprint_number_table
= Qnil
;
1073 /* Construct Vprint_number_table for print-gensym and print-circle. */
1074 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1076 /* Construct Vprint_number_table.
1077 This increments print_number_index for the objects added. */
1079 print_preprocess (obj
);
1081 if (HASH_TABLE_P (Vprint_number_table
))
1082 { /* Remove unnecessary objects, which appear only once in OBJ;
1083 that is, whose status is Qt.
1084 Maybe a better way to do that is to copy elements to
1085 a new hash table. */
1086 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vprint_number_table
);
1089 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
1090 if (!NILP (HASH_HASH (h
, i
))
1091 && EQ (HASH_VALUE (h
, i
), Qt
))
1092 Fremhash (HASH_KEY (h
, i
), Vprint_number_table
);
1097 print_object (obj
, printcharfun
, escapeflag
);
1100 #define PRINT_CIRCLE_CANDIDATE_P(obj) \
1101 (STRINGP (obj) || CONSP (obj) \
1102 || (VECTORLIKEP (obj) \
1103 && (VECTORP (obj) || COMPILEDP (obj) \
1104 || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \
1105 || HASH_TABLE_P (obj) || FONTP (obj))) \
1106 || (! NILP (Vprint_gensym) \
1108 && !SYMBOL_INTERNED_P (obj)))
1110 /* Construct Vprint_number_table according to the structure of OBJ.
1111 OBJ itself and all its elements will be added to Vprint_number_table
1112 recursively if it is a list, vector, compiled function, char-table,
1113 string (its text properties will be traced), or a symbol that has
1114 no obarray (this is for the print-gensym feature).
1115 The status fields of Vprint_number_table mean whether each object appears
1116 more than once in OBJ: Qnil at the first time, and Qt after that . */
1118 print_preprocess (Lisp_Object obj
)
1123 Lisp_Object halftail
;
1125 /* Avoid infinite recursion for circular nested structure
1126 in the case where Vprint_circle is nil. */
1127 if (NILP (Vprint_circle
))
1129 /* Give up if we go so deep that print_object will get an error. */
1130 /* See similar code in print_object. */
1131 if (print_depth
>= PRINT_CIRCLE
)
1132 error ("Apparently circular structure being printed");
1134 for (i
= 0; i
< print_depth
; i
++)
1135 if (EQ (obj
, being_printed
[i
]))
1137 being_printed
[print_depth
] = obj
;
1144 if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1146 if (!HASH_TABLE_P (Vprint_number_table
))
1148 Lisp_Object args
[2];
1151 Vprint_number_table
= Fmake_hash_table (2, args
);
1154 /* In case print-circle is nil and print-gensym is t,
1155 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1156 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1158 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1160 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1161 always print the gensym with a number. This is a special for
1162 the lisp function byte-compile-output-docform. */
1163 || (!NILP (Vprint_continuous_numbering
)
1165 && !SYMBOL_INTERNED_P (obj
)))
1166 { /* OBJ appears more than once. Let's remember that. */
1167 if (!INTEGERP (num
))
1169 print_number_index
++;
1170 /* Negative number indicates it hasn't been printed yet. */
1171 Fputhash (obj
, make_number (- print_number_index
),
1172 Vprint_number_table
);
1178 /* OBJ is not yet recorded. Let's add to the table. */
1179 Fputhash (obj
, Qt
, Vprint_number_table
);
1182 switch (XTYPE (obj
))
1185 /* A string may have text properties, which can be circular. */
1186 traverse_intervals_noorder (STRING_INTERVALS (obj
),
1187 print_preprocess_string
, Qnil
);
1191 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1192 just as in print_object. */
1193 if (loop_count
&& EQ (obj
, halftail
))
1195 print_preprocess (XCAR (obj
));
1198 if (!(loop_count
& 1))
1199 halftail
= XCDR (halftail
);
1202 case Lisp_Vectorlike
:
1204 if (size
& PSEUDOVECTOR_FLAG
)
1205 size
&= PSEUDOVECTOR_SIZE_MASK
;
1206 for (i
= 0; i
< size
; i
++)
1207 print_preprocess (XVECTOR (obj
)->contents
[i
]);
1208 if (HASH_TABLE_P (obj
))
1209 { /* For hash tables, the key_and_value slot is past
1210 `size' because it needs to be marked specially in case
1211 the table is weak. */
1212 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1213 print_preprocess (h
->key_and_value
);
1225 print_preprocess_string (INTERVAL interval
, Lisp_Object arg
)
1227 print_preprocess (interval
->plist
);
1230 static void print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
);
1232 #define PRINT_STRING_NON_CHARSET_FOUND 1
1233 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1235 /* Bitwise or of the above macros. */
1236 static int print_check_string_result
;
1239 print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
)
1243 if (NILP (interval
->plist
)
1244 || (print_check_string_result
== (PRINT_STRING_NON_CHARSET_FOUND
1245 | PRINT_STRING_UNSAFE_CHARSET_FOUND
)))
1247 for (val
= interval
->plist
; CONSP (val
) && ! EQ (XCAR (val
), Qcharset
);
1248 val
= XCDR (XCDR (val
)));
1251 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1254 if (! (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
))
1256 if (! EQ (val
, interval
->plist
)
1257 || CONSP (XCDR (XCDR (val
))))
1258 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1260 if (NILP (Vprint_charset_text_property
)
1261 || ! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1264 ptrdiff_t charpos
= interval
->position
;
1265 ptrdiff_t bytepos
= string_char_to_byte (string
, charpos
);
1266 Lisp_Object charset
;
1268 charset
= XCAR (XCDR (val
));
1269 for (i
= 0; i
< LENGTH (interval
); i
++)
1271 FETCH_STRING_CHAR_ADVANCE (c
, string
, charpos
, bytepos
);
1272 if (! ASCII_CHAR_P (c
)
1273 && ! EQ (CHARSET_NAME (CHAR_CHARSET (c
)), charset
))
1275 print_check_string_result
|= PRINT_STRING_UNSAFE_CHARSET_FOUND
;
1282 /* The value is (charset . nil). */
1283 static Lisp_Object print_prune_charset_plist
;
1286 print_prune_string_charset (Lisp_Object string
)
1288 print_check_string_result
= 0;
1289 traverse_intervals (STRING_INTERVALS (string
), 0,
1290 print_check_string_charset_prop
, string
);
1291 if (! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1293 string
= Fcopy_sequence (string
);
1294 if (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
)
1296 if (NILP (print_prune_charset_plist
))
1297 print_prune_charset_plist
= Fcons (Qcharset
, Qnil
);
1298 Fremove_text_properties (make_number (0),
1299 make_number (SCHARS (string
)),
1300 print_prune_charset_plist
, string
);
1303 Fset_text_properties (make_number (0), make_number (SCHARS (string
)),
1310 print_object (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
)
1312 char buf
[max (sizeof "from..to..in " + 2 * INT_STRLEN_BOUND (EMACS_INT
),
1313 max (sizeof " . #" + INT_STRLEN_BOUND (printmax_t
),
1318 /* Detect circularities and truncate them. */
1319 if (NILP (Vprint_circle
))
1321 /* Simple but incomplete way. */
1324 /* See similar code in print_preprocess. */
1325 if (print_depth
>= PRINT_CIRCLE
)
1326 error ("Apparently circular structure being printed");
1328 for (i
= 0; i
< print_depth
; i
++)
1329 if (EQ (obj
, being_printed
[i
]))
1331 sprintf (buf
, "#%d", i
);
1332 strout (buf
, -1, -1, printcharfun
);
1335 being_printed
[print_depth
] = obj
;
1337 else if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1339 /* With the print-circle feature. */
1340 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1343 EMACS_INT n
= XINT (num
);
1345 { /* Add a prefix #n= if OBJ has not yet been printed;
1346 that is, its status field is nil. */
1347 sprintf (buf
, "#%"pI
"d=", -n
);
1348 strout (buf
, -1, -1, printcharfun
);
1349 /* OBJ is going to be printed. Remember that fact. */
1350 Fputhash (obj
, make_number (- n
), Vprint_number_table
);
1354 /* Just print #n# if OBJ has already been printed. */
1355 sprintf (buf
, "#%"pI
"d#", n
);
1356 strout (buf
, -1, -1, printcharfun
);
1364 switch (XTYPE (obj
))
1367 sprintf (buf
, "%"pI
"d", XINT (obj
));
1368 strout (buf
, -1, -1, printcharfun
);
1373 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
1375 float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1376 strout (pigbuf
, -1, -1, printcharfun
);
1382 print_string (obj
, printcharfun
);
1385 register ptrdiff_t i_byte
;
1386 struct gcpro gcpro1
;
1388 ptrdiff_t size_byte
;
1389 /* 1 means we must ensure that the next character we output
1390 cannot be taken as part of a hex character escape. */
1391 int need_nonhex
= 0;
1392 int multibyte
= STRING_MULTIBYTE (obj
);
1396 if (! EQ (Vprint_charset_text_property
, Qt
))
1397 obj
= print_prune_string_charset (obj
);
1399 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1407 size_byte
= SBYTES (obj
);
1409 for (i_byte
= 0; i_byte
< size_byte
;)
1411 /* Here, we must convert each multi-byte form to the
1412 corresponding character code before handing it to PRINTCHAR. */
1418 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
, len
);
1426 if (c
== '\n' && print_escape_newlines
)
1431 else if (c
== '\f' && print_escape_newlines
)
1437 && (CHAR_BYTE8_P (c
)
1438 || (! ASCII_CHAR_P (c
) && print_escape_multibyte
)))
1440 /* When multibyte is disabled,
1441 print multibyte string chars using hex escapes.
1442 For a char code that could be in a unibyte string,
1443 when found in a multibyte string, always use a hex escape
1444 so it reads back as multibyte. */
1447 if (CHAR_BYTE8_P (c
))
1448 sprintf (outbuf
, "\\%03o", CHAR_TO_BYTE8 (c
));
1451 sprintf (outbuf
, "\\x%04x", c
);
1454 strout (outbuf
, -1, -1, printcharfun
);
1456 else if (! multibyte
1457 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1458 && print_escape_nonascii
)
1460 /* When printing in a multibyte buffer
1461 or when explicitly requested,
1462 print single-byte non-ASCII string chars
1463 using octal escapes. */
1465 sprintf (outbuf
, "\\%03o", c
);
1466 strout (outbuf
, -1, -1, printcharfun
);
1470 /* If we just had a hex escape, and this character
1471 could be taken as part of it,
1472 output `\ ' to prevent that. */
1476 if ((c
>= 'a' && c
<= 'f')
1477 || (c
>= 'A' && c
<= 'F')
1478 || (c
>= '0' && c
<= '9'))
1479 strout ("\\ ", -1, -1, printcharfun
);
1482 if (c
== '\"' || c
== '\\')
1489 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1491 traverse_intervals (STRING_INTERVALS (obj
),
1492 0, print_interval
, printcharfun
);
1502 register int confusing
;
1503 register unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1504 register unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1506 ptrdiff_t i
, i_byte
;
1507 ptrdiff_t size_byte
;
1510 name
= SYMBOL_NAME (obj
);
1512 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1515 /* If symbol name begins with a digit, and ends with a digit,
1516 and contains nothing but digits and `e', it could be treated
1517 as a number. So set CONFUSING.
1519 Symbols that contain periods could also be taken as numbers,
1520 but periods are always escaped, so we don't have to worry
1522 else if (*p
>= '0' && *p
<= '9'
1523 && end
[-1] >= '0' && end
[-1] <= '9')
1525 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1526 /* Needed for \2e10. */
1527 || *p
== 'e' || *p
== 'E'))
1529 confusing
= (end
== p
);
1534 size_byte
= SBYTES (name
);
1536 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1541 else if (size_byte
== 0)
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. */
1552 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1557 if (c
== '\"' || c
== '\\' || c
== '\''
1558 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1559 || c
== ',' || c
== '.' || c
== '`'
1560 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1562 PRINTCHAR ('\\'), confusing
= 0;
1570 /* If deeper than spec'd depth, print placeholder. */
1571 if (INTEGERP (Vprint_level
)
1572 && print_depth
> XINT (Vprint_level
))
1573 strout ("...", -1, -1, printcharfun
);
1574 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1575 && (EQ (XCAR (obj
), Qquote
)))
1578 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1580 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1581 && (EQ (XCAR (obj
), Qfunction
)))
1585 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1587 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1588 && ((EQ (XCAR (obj
), Qbackquote
))))
1590 print_object (XCAR (obj
), printcharfun
, 0);
1591 new_backquote_output
++;
1592 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1593 new_backquote_output
--;
1595 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1596 && new_backquote_output
1597 && ((EQ (XCAR (obj
), Qbackquote
)
1598 || EQ (XCAR (obj
), Qcomma
)
1599 || EQ (XCAR (obj
), Qcomma_at
)
1600 || EQ (XCAR (obj
), Qcomma_dot
))))
1602 print_object (XCAR (obj
), printcharfun
, 0);
1603 new_backquote_output
--;
1604 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1605 new_backquote_output
++;
1612 printmax_t i
, print_length
;
1613 Lisp_Object halftail
= obj
;
1615 /* Negative values of print-length are invalid in CL.
1616 Treat them like nil, as CMUCL does. */
1617 if (NATNUMP (Vprint_length
))
1618 print_length
= XFASTINT (Vprint_length
);
1620 print_length
= TYPE_MAXIMUM (printmax_t
);
1625 /* Detect circular list. */
1626 if (NILP (Vprint_circle
))
1628 /* Simple but incomplete way. */
1629 if (i
!= 0 && EQ (obj
, halftail
))
1631 sprintf (buf
, " . #%"pMd
, i
/ 2);
1632 strout (buf
, -1, -1, printcharfun
);
1638 /* With the print-circle feature. */
1641 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1644 strout (" . ", 3, 3, printcharfun
);
1645 print_object (obj
, printcharfun
, escapeflag
);
1654 if (print_length
<= i
)
1656 strout ("...", 3, 3, printcharfun
);
1661 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1665 halftail
= XCDR (halftail
);
1669 /* OBJ non-nil here means it's the end of a dotted list. */
1672 strout (" . ", 3, 3, printcharfun
);
1673 print_object (obj
, printcharfun
, escapeflag
);
1681 case Lisp_Vectorlike
:
1686 strout ("#<process ", -1, -1, printcharfun
);
1687 print_string (XPROCESS (obj
)->name
, printcharfun
);
1691 print_string (XPROCESS (obj
)->name
, printcharfun
);
1693 else if (BOOL_VECTOR_P (obj
))
1696 register unsigned char c
;
1697 struct gcpro gcpro1
;
1698 ptrdiff_t size_in_chars
1699 = ((XBOOL_VECTOR (obj
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
1700 / BOOL_VECTOR_BITS_PER_CHAR
);
1706 sprintf (buf
, "%"pI
"d", XBOOL_VECTOR (obj
)->size
);
1707 strout (buf
, -1, -1, printcharfun
);
1710 /* Don't print more characters than the specified maximum.
1711 Negative values of print-length are invalid. Treat them
1712 like a print-length of nil. */
1713 if (NATNUMP (Vprint_length
)
1714 && XFASTINT (Vprint_length
) < size_in_chars
)
1715 size_in_chars
= XFASTINT (Vprint_length
);
1717 for (i
= 0; i
< size_in_chars
; i
++)
1720 c
= XBOOL_VECTOR (obj
)->data
[i
];
1721 if (c
== '\n' && print_escape_newlines
)
1726 else if (c
== '\f' && print_escape_newlines
)
1731 else if (c
> '\177')
1733 /* Use octal escapes to avoid encoding issues. */
1735 PRINTCHAR ('0' + ((c
>> 6) & 3));
1736 PRINTCHAR ('0' + ((c
>> 3) & 7));
1737 PRINTCHAR ('0' + (c
& 7));
1741 if (c
== '\"' || c
== '\\')
1750 else if (SUBRP (obj
))
1752 strout ("#<subr ", -1, -1, printcharfun
);
1753 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
);
1756 else if (WINDOWP (obj
))
1758 strout ("#<window ", -1, -1, printcharfun
);
1759 sprintf (buf
, "%"pI
"d", XFASTINT (XWINDOW (obj
)->sequence_number
));
1760 strout (buf
, -1, -1, printcharfun
);
1761 if (!NILP (XWINDOW (obj
)->buffer
))
1763 strout (" on ", -1, -1, printcharfun
);
1764 print_string (BVAR (XBUFFER (XWINDOW (obj
)->buffer
), name
), printcharfun
);
1768 else if (TERMINALP (obj
))
1770 struct terminal
*t
= XTERMINAL (obj
);
1771 strout ("#<terminal ", -1, -1, printcharfun
);
1772 sprintf (buf
, "%d", t
->id
);
1773 strout (buf
, -1, -1, printcharfun
);
1776 strout (" on ", -1, -1, printcharfun
);
1777 strout (t
->name
, -1, -1, printcharfun
);
1781 else if (HASH_TABLE_P (obj
))
1783 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1785 ptrdiff_t real_size
, size
;
1787 strout ("#<hash-table", -1, -1, printcharfun
);
1788 if (SYMBOLP (h
->test
))
1792 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
);
1794 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
);
1796 sprintf (buf
, "%"pD
"d/%"pD
"d", h
->count
, ASIZE (h
->next
));
1797 strout (buf
, -1, -1, printcharfun
);
1799 sprintf (buf
, " %p", h
);
1800 strout (buf
, -1, -1, printcharfun
);
1803 /* Implement a readable output, e.g.:
1804 #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
1805 /* Always print the size. */
1806 sprintf (buf
, "#s(hash-table size %"pD
"d", ASIZE (h
->next
));
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
, " %p", 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 ptrdiff_t size
= ASIZE (obj
);
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 ptrdiff_t 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 %"pD
"d", 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 %"pD
"d to %"pD
"d in ",
1996 marker_position (OVERLAY_START (obj
)),
1997 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=%p int=%"pD
"d",
2014 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%08"pD
"x)", ASIZE (obj
));
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 DEFSYM (Qtemp_buffer_setup_hook
, "temp-buffer-setup-hook");
2070 DEFVAR_LISP ("standard-output", Vstandard_output
,
2071 doc
: /* Output stream `print' uses by default for outputting a character.
2072 This may be any function of one argument.
2073 It may also be a buffer (output is inserted before point)
2074 or a marker (output is inserted and the marker is advanced)
2075 or the symbol t (output appears in the echo area). */);
2076 Vstandard_output
= Qt
;
2077 DEFSYM (Qstandard_output
, "standard-output");
2079 DEFVAR_LISP ("float-output-format", Vfloat_output_format
,
2080 doc
: /* The format descriptor string used to print floats.
2081 This is a %-spec like those accepted by `printf' in C,
2082 but with some restrictions. It must start with the two characters `%.'.
2083 After that comes an integer precision specification,
2084 and then a letter which controls the format.
2085 The letters allowed are `e', `f' and `g'.
2086 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2087 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2088 Use `g' to choose the shorter of those two formats for the number at hand.
2089 The precision in any of these cases is the number of digits following
2090 the decimal point. With `f', a precision of 0 means to omit the
2091 decimal point. 0 is not allowed with `e' or `g'.
2093 A value of nil means to use the shortest notation
2094 that represents the number without losing information. */);
2095 Vfloat_output_format
= Qnil
;
2096 DEFSYM (Qfloat_output_format
, "float-output-format");
2098 DEFVAR_LISP ("print-length", Vprint_length
,
2099 doc
: /* Maximum length of list to print before abbreviating.
2100 A value of nil means no limit. See also `eval-expression-print-length'. */);
2101 Vprint_length
= Qnil
;
2103 DEFVAR_LISP ("print-level", Vprint_level
,
2104 doc
: /* Maximum depth of list nesting to print before abbreviating.
2105 A value of nil means no limit. See also `eval-expression-print-level'. */);
2106 Vprint_level
= Qnil
;
2108 DEFVAR_BOOL ("print-escape-newlines", print_escape_newlines
,
2109 doc
: /* Non-nil means print newlines in strings as `\\n'.
2110 Also print formfeeds as `\\f'. */);
2111 print_escape_newlines
= 0;
2113 DEFVAR_BOOL ("print-escape-nonascii", print_escape_nonascii
,
2114 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2115 \(OOO is the octal representation of the character code.)
2116 Only single-byte characters are affected, and only in `prin1'.
2117 When the output goes in a multibyte buffer, this feature is
2118 enabled regardless of the value of the variable. */);
2119 print_escape_nonascii
= 0;
2121 DEFVAR_BOOL ("print-escape-multibyte", print_escape_multibyte
,
2122 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2123 \(XXXX is the hex representation of the character code.)
2124 This affects only `prin1'. */);
2125 print_escape_multibyte
= 0;
2127 DEFVAR_BOOL ("print-quoted", print_quoted
,
2128 doc
: /* Non-nil means print quoted forms with reader syntax.
2129 I.e., (quote foo) prints as 'foo, (function foo) as #'foo. */);
2132 DEFVAR_LISP ("print-gensym", Vprint_gensym
,
2133 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2134 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2135 When the uninterned symbol appears within a recursive data structure,
2136 and the symbol appears more than once, in addition use the #N# and #N=
2137 constructs as needed, so that multiple references to the same symbol are
2138 shared once again when the text is read back. */);
2139 Vprint_gensym
= Qnil
;
2141 DEFVAR_LISP ("print-circle", Vprint_circle
,
2142 doc
: /* Non-nil means print recursive structures using #N= and #N# syntax.
2143 If nil, printing proceeds recursively and may lead to
2144 `max-lisp-eval-depth' being exceeded or an error may occur:
2145 \"Apparently circular structure being printed.\" Also see
2146 `print-length' and `print-level'.
2147 If non-nil, shared substructures anywhere in the structure are printed
2148 with `#N=' before the first occurrence (in the order of the print
2149 representation) and `#N#' in place of each subsequent occurrence,
2150 where N is a positive decimal integer. */);
2151 Vprint_circle
= Qnil
;
2153 DEFVAR_LISP ("print-continuous-numbering", Vprint_continuous_numbering
,
2154 doc
: /* Non-nil means number continuously across print calls.
2155 This affects the numbers printed for #N= labels and #M# references.
2156 See also `print-circle', `print-gensym', and `print-number-table'.
2157 This variable should not be set with `setq'; bind it with a `let' instead. */);
2158 Vprint_continuous_numbering
= Qnil
;
2160 DEFVAR_LISP ("print-number-table", Vprint_number_table
,
2161 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2162 The Lisp printer uses this vector to detect Lisp objects referenced more
2165 When you bind `print-continuous-numbering' to t, you should probably
2166 also bind `print-number-table' to nil. This ensures that the value of
2167 `print-number-table' can be garbage-collected once the printing is
2168 done. If all elements of `print-number-table' are nil, it means that
2169 the printing done so far has not found any shared structure or objects
2170 that need to be recorded in the table. */);
2171 Vprint_number_table
= Qnil
;
2173 DEFVAR_LISP ("print-charset-text-property", Vprint_charset_text_property
,
2174 doc
: /* A flag to control printing of `charset' text property on printing a string.
2175 The value must be nil, t, or `default'.
2177 If the value is nil, don't print the text property `charset'.
2179 If the value is t, always print the text property `charset'.
2181 If the value is `default', print the text property `charset' only when
2182 the value is different from what is guessed in the current charset
2184 Vprint_charset_text_property
= Qdefault
;
2186 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2187 staticpro (&Vprin1_to_string_buffer
);
2190 defsubr (&Sprin1_to_string
);
2191 defsubr (&Serror_message_string
);
2195 defsubr (&Swrite_char
);
2196 defsubr (&Sexternal_debugging_output
);
2197 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2198 defsubr (&Sredirect_debugging_output
);
2201 DEFSYM (Qexternal_debugging_output
, "external-debugging-output");
2202 DEFSYM (Qprint_escape_newlines
, "print-escape-newlines");
2203 DEFSYM (Qprint_escape_multibyte
, "print-escape-multibyte");
2204 DEFSYM (Qprint_escape_nonascii
, "print-escape-nonascii");
2206 print_prune_charset_plist
= Qnil
;
2207 staticpro (&print_prune_charset_plist
);