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/>. */
26 #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
;
859 write_string_1 (context
, -1, stream
);
861 /* If we know from where the error was signaled, show it in
863 if (!NILP (caller
) && SYMBOLP (caller
))
865 Lisp_Object cname
= SYMBOL_NAME (caller
);
868 SAFE_ALLOCA (name
, char *, SBYTES (cname
));
869 memcpy (name
, SDATA (cname
), SBYTES (cname
));
870 message_dolog (name
, SBYTES (cname
), 0, 0);
871 message_dolog (": ", 2, 0, 0);
875 errname
= Fcar (data
);
877 if (EQ (errname
, Qerror
))
882 errmsg
= Fcar (data
);
887 Lisp_Object error_conditions
= Fget (errname
, Qerror_conditions
);
888 errmsg
= Fget (errname
, Qerror_message
);
889 file_error
= Fmemq (Qfile_error
, error_conditions
);
892 /* Print an error message including the data items. */
894 tail
= Fcdr_safe (data
);
897 /* For file-error, make error message by concatenating
898 all the data items. They are all strings. */
899 if (!NILP (file_error
) && CONSP (tail
))
900 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
903 const char *sep
= ": ";
905 if (!STRINGP (errmsg
))
906 write_string_1 ("peculiar error", -1, stream
);
907 else if (SCHARS (errmsg
))
908 Fprinc (errmsg
, stream
);
912 for (; CONSP (tail
); tail
= XCDR (tail
), sep
= ", ")
917 write_string_1 (sep
, 2, stream
);
919 if (!NILP (file_error
)
920 || EQ (errname
, Qend_of_file
) || EQ (errname
, Quser_error
))
921 Fprinc (obj
, stream
);
923 Fprin1 (obj
, stream
);
933 * The buffer should be at least as large as the max string size of the
934 * largest float, printed in the biggest notation. This is undoubtedly
935 * 20d float_output_format, with the negative of the C-constant "HUGE"
938 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
940 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
941 * case of -1e307 in 20d float_output_format. What is one to do (short of
942 * re-writing _doprnt to be more sane)?
944 * Given the above, the buffer must be least FLOAT_TO_STRING_BUFSIZE bytes.
948 float_to_string (char *buf
, double data
)
954 /* Check for plus infinity in a way that won't lose
955 if there is no plus infinity. */
956 if (data
== data
/ 2 && data
> 1.0)
958 static char const infinity_string
[] = "1.0e+INF";
959 strcpy (buf
, infinity_string
);
960 return sizeof infinity_string
- 1;
962 /* Likewise for minus infinity. */
963 if (data
== data
/ 2 && data
< -1.0)
965 static char const minus_infinity_string
[] = "-1.0e+INF";
966 strcpy (buf
, minus_infinity_string
);
967 return sizeof minus_infinity_string
- 1;
969 /* Check for NaN in a way that won't fail if there are no NaNs. */
970 if (! (data
* 0.0 >= 0.0))
972 /* Prepend "-" if the NaN's sign bit is negative.
973 The sign bit of a double is the bit that is 1 in -0.0. */
974 static char const NaN_string
[] = "0.0e+NaN";
976 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
979 u_minus_zero
.d
= - 0.0;
980 for (i
= 0; i
< sizeof (double); i
++)
981 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
988 strcpy (buf
+ negative
, NaN_string
);
989 return negative
+ sizeof NaN_string
- 1;
992 if (NILP (Vfloat_output_format
)
993 || !STRINGP (Vfloat_output_format
))
996 /* Generate the fewest number of digits that represent the
997 floating point value without losing information. */
998 len
= dtoastr (buf
, FLOAT_TO_STRING_BUFSIZE
- 2, 0, 0, data
);
999 /* The decimal point must be printed, or the byte compiler can
1000 get confused (Bug#8033). */
1003 else /* oink oink */
1005 /* Check that the spec we have is fully valid.
1006 This means not only valid for printf,
1007 but meant for floats, and reasonable. */
1008 cp
= SSDATA (Vfloat_output_format
);
1017 /* Check the width specification. */
1019 if ('0' <= *cp
&& *cp
<= '9')
1024 width
= (width
* 10) + (*cp
++ - '0');
1025 if (DBL_DIG
< width
)
1028 while (*cp
>= '0' && *cp
<= '9');
1030 /* A precision of zero is valid only for %f. */
1031 if (width
== 0 && *cp
!= 'f')
1035 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1041 len
= sprintf (buf
, SSDATA (Vfloat_output_format
), data
);
1044 /* Make sure there is a decimal point with digit after, or an
1045 exponent, so that the value is readable as a float. But don't do
1046 this with "%.0f"; it's valid for that not to produce a decimal
1047 point. Note that width can be 0 only for %.0f. */
1050 for (cp
= buf
; *cp
; cp
++)
1051 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1054 if (*cp
== '.' && cp
[1] == 0)
1074 print (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
)
1076 new_backquote_output
= 0;
1078 /* Reset print_number_index and Vprint_number_table only when
1079 the variable Vprint_continuous_numbering is nil. Otherwise,
1080 the values of these variables will be kept between several
1082 if (NILP (Vprint_continuous_numbering
)
1083 || NILP (Vprint_number_table
))
1085 print_number_index
= 0;
1086 Vprint_number_table
= Qnil
;
1089 /* Construct Vprint_number_table for print-gensym and print-circle. */
1090 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1092 /* Construct Vprint_number_table.
1093 This increments print_number_index for the objects added. */
1095 print_preprocess (obj
);
1097 if (HASH_TABLE_P (Vprint_number_table
))
1098 { /* Remove unnecessary objects, which appear only once in OBJ;
1099 that is, whose status is Qt. */
1100 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vprint_number_table
);
1103 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
1104 if (!NILP (HASH_HASH (h
, i
))
1105 && EQ (HASH_VALUE (h
, i
), Qt
))
1106 Fremhash (HASH_KEY (h
, i
), Vprint_number_table
);
1111 print_object (obj
, printcharfun
, escapeflag
);
1114 #define PRINT_CIRCLE_CANDIDATE_P(obj) \
1115 (STRINGP (obj) || CONSP (obj) \
1116 || (VECTORLIKEP (obj) \
1117 && (VECTORP (obj) || COMPILEDP (obj) \
1118 || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \
1119 || HASH_TABLE_P (obj) || FONTP (obj))) \
1120 || (! NILP (Vprint_gensym) \
1122 && !SYMBOL_INTERNED_P (obj)))
1124 /* Construct Vprint_number_table according to the structure of OBJ.
1125 OBJ itself and all its elements will be added to Vprint_number_table
1126 recursively if it is a list, vector, compiled function, char-table,
1127 string (its text properties will be traced), or a symbol that has
1128 no obarray (this is for the print-gensym feature).
1129 The status fields of Vprint_number_table mean whether each object appears
1130 more than once in OBJ: Qnil at the first time, and Qt after that . */
1132 print_preprocess (Lisp_Object obj
)
1137 Lisp_Object halftail
;
1139 /* Avoid infinite recursion for circular nested structure
1140 in the case where Vprint_circle is nil. */
1141 if (NILP (Vprint_circle
))
1143 /* Give up if we go so deep that print_object will get an error. */
1144 /* See similar code in print_object. */
1145 if (print_depth
>= PRINT_CIRCLE
)
1146 error ("Apparently circular structure being printed");
1148 for (i
= 0; i
< print_depth
; i
++)
1149 if (EQ (obj
, being_printed
[i
]))
1151 being_printed
[print_depth
] = obj
;
1158 if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1160 if (!HASH_TABLE_P (Vprint_number_table
))
1162 Lisp_Object args
[2];
1165 Vprint_number_table
= Fmake_hash_table (2, args
);
1168 /* In case print-circle is nil and print-gensym is t,
1169 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1170 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1172 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1174 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1175 always print the gensym with a number. This is a special for
1176 the lisp function byte-compile-output-docform. */
1177 || (!NILP (Vprint_continuous_numbering
)
1179 && !SYMBOL_INTERNED_P (obj
)))
1180 { /* OBJ appears more than once. Let's remember that. */
1181 if (!INTEGERP (num
))
1183 print_number_index
++;
1184 /* Negative number indicates it hasn't been printed yet. */
1185 Fputhash (obj
, make_number (- print_number_index
),
1186 Vprint_number_table
);
1192 /* OBJ is not yet recorded. Let's add to the table. */
1193 Fputhash (obj
, Qt
, Vprint_number_table
);
1196 switch (XTYPE (obj
))
1199 /* A string may have text properties, which can be circular. */
1200 traverse_intervals_noorder (STRING_INTERVALS (obj
),
1201 print_preprocess_string
, Qnil
);
1205 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1206 just as in print_object. */
1207 if (loop_count
&& EQ (obj
, halftail
))
1209 print_preprocess (XCAR (obj
));
1212 if (!(loop_count
& 1))
1213 halftail
= XCDR (halftail
);
1216 case Lisp_Vectorlike
:
1218 if (size
& PSEUDOVECTOR_FLAG
)
1219 size
&= PSEUDOVECTOR_SIZE_MASK
;
1220 for (i
= 0; i
< size
; i
++)
1221 print_preprocess (AREF (obj
, i
));
1222 if (HASH_TABLE_P (obj
))
1223 { /* For hash tables, the key_and_value slot is past
1224 `size' because it needs to be marked specially in case
1225 the table is weak. */
1226 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1227 print_preprocess (h
->key_and_value
);
1239 print_preprocess_string (INTERVAL interval
, Lisp_Object arg
)
1241 print_preprocess (interval
->plist
);
1244 static void print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
);
1246 #define PRINT_STRING_NON_CHARSET_FOUND 1
1247 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1249 /* Bitwise or of the above macros. */
1250 static int print_check_string_result
;
1253 print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
)
1257 if (NILP (interval
->plist
)
1258 || (print_check_string_result
== (PRINT_STRING_NON_CHARSET_FOUND
1259 | PRINT_STRING_UNSAFE_CHARSET_FOUND
)))
1261 for (val
= interval
->plist
; CONSP (val
) && ! EQ (XCAR (val
), Qcharset
);
1262 val
= XCDR (XCDR (val
)));
1265 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1268 if (! (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
))
1270 if (! EQ (val
, interval
->plist
)
1271 || CONSP (XCDR (XCDR (val
))))
1272 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1274 if (NILP (Vprint_charset_text_property
)
1275 || ! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1278 ptrdiff_t charpos
= interval
->position
;
1279 ptrdiff_t bytepos
= string_char_to_byte (string
, charpos
);
1280 Lisp_Object charset
;
1282 charset
= XCAR (XCDR (val
));
1283 for (i
= 0; i
< LENGTH (interval
); i
++)
1285 FETCH_STRING_CHAR_ADVANCE (c
, string
, charpos
, bytepos
);
1286 if (! ASCII_CHAR_P (c
)
1287 && ! EQ (CHARSET_NAME (CHAR_CHARSET (c
)), charset
))
1289 print_check_string_result
|= PRINT_STRING_UNSAFE_CHARSET_FOUND
;
1296 /* The value is (charset . nil). */
1297 static Lisp_Object print_prune_charset_plist
;
1300 print_prune_string_charset (Lisp_Object string
)
1302 print_check_string_result
= 0;
1303 traverse_intervals (STRING_INTERVALS (string
), 0,
1304 print_check_string_charset_prop
, string
);
1305 if (! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1307 string
= Fcopy_sequence (string
);
1308 if (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
)
1310 if (NILP (print_prune_charset_plist
))
1311 print_prune_charset_plist
= Fcons (Qcharset
, Qnil
);
1312 Fremove_text_properties (make_number (0),
1313 make_number (SCHARS (string
)),
1314 print_prune_charset_plist
, string
);
1317 Fset_text_properties (make_number (0), make_number (SCHARS (string
)),
1324 print_object (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
)
1326 char buf
[max (sizeof "from..to..in " + 2 * INT_STRLEN_BOUND (EMACS_INT
),
1327 max (sizeof " . #" + INT_STRLEN_BOUND (printmax_t
),
1332 /* Detect circularities and truncate them. */
1333 if (NILP (Vprint_circle
))
1335 /* Simple but incomplete way. */
1338 /* See similar code in print_preprocess. */
1339 if (print_depth
>= PRINT_CIRCLE
)
1340 error ("Apparently circular structure being printed");
1342 for (i
= 0; i
< print_depth
; i
++)
1343 if (EQ (obj
, being_printed
[i
]))
1345 int len
= sprintf (buf
, "#%d", i
);
1346 strout (buf
, len
, len
, printcharfun
);
1349 being_printed
[print_depth
] = obj
;
1351 else if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1353 /* With the print-circle feature. */
1354 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1357 EMACS_INT n
= XINT (num
);
1359 { /* Add a prefix #n= if OBJ has not yet been printed;
1360 that is, its status field is nil. */
1361 int len
= sprintf (buf
, "#%"pI
"d=", -n
);
1362 strout (buf
, len
, len
, printcharfun
);
1363 /* OBJ is going to be printed. Remember that fact. */
1364 Fputhash (obj
, make_number (- n
), Vprint_number_table
);
1368 /* Just print #n# if OBJ has already been printed. */
1369 int len
= sprintf (buf
, "#%"pI
"d#", n
);
1370 strout (buf
, len
, len
, printcharfun
);
1378 switch (XTYPE (obj
))
1382 int len
= sprintf (buf
, "%"pI
"d", XINT (obj
));
1383 strout (buf
, len
, len
, printcharfun
);
1389 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
1390 int len
= float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1391 strout (pigbuf
, len
, len
, printcharfun
);
1397 print_string (obj
, printcharfun
);
1400 register ptrdiff_t i_byte
;
1401 struct gcpro gcpro1
;
1403 ptrdiff_t size_byte
;
1404 /* 1 means we must ensure that the next character we output
1405 cannot be taken as part of a hex character escape. */
1406 int need_nonhex
= 0;
1407 int multibyte
= STRING_MULTIBYTE (obj
);
1411 if (! EQ (Vprint_charset_text_property
, Qt
))
1412 obj
= print_prune_string_charset (obj
);
1414 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1422 size_byte
= SBYTES (obj
);
1424 for (i_byte
= 0; i_byte
< size_byte
;)
1426 /* Here, we must convert each multi-byte form to the
1427 corresponding character code before handing it to PRINTCHAR. */
1433 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
, len
);
1441 if (c
== '\n' && print_escape_newlines
)
1446 else if (c
== '\f' && print_escape_newlines
)
1452 && (CHAR_BYTE8_P (c
)
1453 || (! ASCII_CHAR_P (c
) && print_escape_multibyte
)))
1455 /* When multibyte is disabled,
1456 print multibyte string chars using hex escapes.
1457 For a char code that could be in a unibyte string,
1458 when found in a multibyte string, always use a hex escape
1459 so it reads back as multibyte. */
1463 if (CHAR_BYTE8_P (c
))
1464 len
= sprintf (outbuf
, "\\%03o", CHAR_TO_BYTE8 (c
));
1467 len
= sprintf (outbuf
, "\\x%04x", c
);
1470 strout (outbuf
, len
, len
, printcharfun
);
1472 else if (! multibyte
1473 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1474 && print_escape_nonascii
)
1476 /* When printing in a multibyte buffer
1477 or when explicitly requested,
1478 print single-byte non-ASCII string chars
1479 using octal escapes. */
1481 int len
= sprintf (outbuf
, "\\%03o", c
);
1482 strout (outbuf
, len
, len
, printcharfun
);
1486 /* If we just had a hex escape, and this character
1487 could be taken as part of it,
1488 output `\ ' to prevent that. */
1492 if ((c
>= 'a' && c
<= 'f')
1493 || (c
>= 'A' && c
<= 'F')
1494 || (c
>= '0' && c
<= '9'))
1495 strout ("\\ ", -1, -1, printcharfun
);
1498 if (c
== '\"' || c
== '\\')
1505 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1507 traverse_intervals (STRING_INTERVALS (obj
),
1508 0, print_interval
, printcharfun
);
1518 register int confusing
;
1519 register unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1520 register unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1522 ptrdiff_t i
, i_byte
;
1523 ptrdiff_t size_byte
;
1526 name
= SYMBOL_NAME (obj
);
1528 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1531 /* If symbol name begins with a digit, and ends with a digit,
1532 and contains nothing but digits and `e', it could be treated
1533 as a number. So set CONFUSING.
1535 Symbols that contain periods could also be taken as numbers,
1536 but periods are always escaped, so we don't have to worry
1538 else if (*p
>= '0' && *p
<= '9'
1539 && end
[-1] >= '0' && end
[-1] <= '9')
1541 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1542 /* Needed for \2e10. */
1543 || *p
== 'e' || *p
== 'E'))
1545 confusing
= (end
== p
);
1550 size_byte
= SBYTES (name
);
1552 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1557 else if (size_byte
== 0)
1564 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1566 /* Here, we must convert each multi-byte form to the
1567 corresponding character code before handing it to PRINTCHAR. */
1568 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1573 if (c
== '\"' || c
== '\\' || c
== '\''
1574 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1575 || c
== ',' || c
== '.' || c
== '`'
1576 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1578 PRINTCHAR ('\\'), confusing
= 0;
1586 /* If deeper than spec'd depth, print placeholder. */
1587 if (INTEGERP (Vprint_level
)
1588 && print_depth
> XINT (Vprint_level
))
1589 strout ("...", -1, -1, printcharfun
);
1590 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1591 && (EQ (XCAR (obj
), Qquote
)))
1594 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1596 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1597 && (EQ (XCAR (obj
), Qfunction
)))
1601 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1603 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1604 && ((EQ (XCAR (obj
), Qbackquote
))))
1606 print_object (XCAR (obj
), printcharfun
, 0);
1607 new_backquote_output
++;
1608 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1609 new_backquote_output
--;
1611 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1612 && new_backquote_output
1613 && ((EQ (XCAR (obj
), Qbackquote
)
1614 || EQ (XCAR (obj
), Qcomma
)
1615 || EQ (XCAR (obj
), Qcomma_at
)
1616 || EQ (XCAR (obj
), Qcomma_dot
))))
1618 print_object (XCAR (obj
), printcharfun
, 0);
1619 new_backquote_output
--;
1620 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1621 new_backquote_output
++;
1628 printmax_t i
, print_length
;
1629 Lisp_Object halftail
= obj
;
1631 /* Negative values of print-length are invalid in CL.
1632 Treat them like nil, as CMUCL does. */
1633 if (NATNUMP (Vprint_length
))
1634 print_length
= XFASTINT (Vprint_length
);
1636 print_length
= TYPE_MAXIMUM (printmax_t
);
1641 /* Detect circular list. */
1642 if (NILP (Vprint_circle
))
1644 /* Simple but incomplete way. */
1645 if (i
!= 0 && EQ (obj
, halftail
))
1647 int len
= sprintf (buf
, " . #%"pMd
, i
/ 2);
1648 strout (buf
, len
, len
, printcharfun
);
1654 /* With the print-circle feature. */
1657 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1660 strout (" . ", 3, 3, printcharfun
);
1661 print_object (obj
, printcharfun
, escapeflag
);
1670 if (print_length
<= i
)
1672 strout ("...", 3, 3, printcharfun
);
1677 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1681 halftail
= XCDR (halftail
);
1685 /* OBJ non-nil here means it's the end of a dotted list. */
1688 strout (" . ", 3, 3, printcharfun
);
1689 print_object (obj
, printcharfun
, escapeflag
);
1697 case Lisp_Vectorlike
:
1702 strout ("#<process ", -1, -1, printcharfun
);
1703 print_string (XPROCESS (obj
)->name
, printcharfun
);
1707 print_string (XPROCESS (obj
)->name
, printcharfun
);
1709 else if (BOOL_VECTOR_P (obj
))
1714 struct gcpro gcpro1
;
1715 ptrdiff_t size_in_chars
1716 = ((XBOOL_VECTOR (obj
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
1717 / BOOL_VECTOR_BITS_PER_CHAR
);
1723 len
= sprintf (buf
, "%"pI
"d", XBOOL_VECTOR (obj
)->size
);
1724 strout (buf
, len
, len
, printcharfun
);
1727 /* Don't print more characters than the specified maximum.
1728 Negative values of print-length are invalid. Treat them
1729 like a print-length of nil. */
1730 if (NATNUMP (Vprint_length
)
1731 && XFASTINT (Vprint_length
) < size_in_chars
)
1732 size_in_chars
= XFASTINT (Vprint_length
);
1734 for (i
= 0; i
< size_in_chars
; i
++)
1737 c
= XBOOL_VECTOR (obj
)->data
[i
];
1738 if (c
== '\n' && print_escape_newlines
)
1743 else if (c
== '\f' && print_escape_newlines
)
1748 else if (c
> '\177')
1750 /* Use octal escapes to avoid encoding issues. */
1752 PRINTCHAR ('0' + ((c
>> 6) & 3));
1753 PRINTCHAR ('0' + ((c
>> 3) & 7));
1754 PRINTCHAR ('0' + (c
& 7));
1758 if (c
== '\"' || c
== '\\')
1767 else if (SUBRP (obj
))
1769 strout ("#<subr ", -1, -1, printcharfun
);
1770 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
);
1773 else if (WINDOWP (obj
))
1776 strout ("#<window ", -1, -1, printcharfun
);
1777 len
= sprintf (buf
, "%d", XWINDOW (obj
)->sequence_number
);
1778 strout (buf
, len
, len
, printcharfun
);
1779 if (!NILP (XWINDOW (obj
)->buffer
))
1781 strout (" on ", -1, -1, printcharfun
);
1782 print_string (BVAR (XBUFFER (XWINDOW (obj
)->buffer
), name
), printcharfun
);
1786 else if (TERMINALP (obj
))
1789 struct terminal
*t
= XTERMINAL (obj
);
1790 strout ("#<terminal ", -1, -1, printcharfun
);
1791 len
= sprintf (buf
, "%d", t
->id
);
1792 strout (buf
, len
, len
, printcharfun
);
1795 strout (" on ", -1, -1, printcharfun
);
1796 strout (t
->name
, -1, -1, printcharfun
);
1800 else if (HASH_TABLE_P (obj
))
1802 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1804 ptrdiff_t real_size
, size
;
1807 strout ("#<hash-table", -1, -1, printcharfun
);
1808 if (SYMBOLP (h
->test
))
1812 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
);
1814 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
);
1816 len
= sprintf (buf
, "%"pD
"d/%"pD
"d", h
->count
, ASIZE (h
->next
));
1817 strout (buf
, len
, len
, printcharfun
);
1819 len
= sprintf (buf
, " %p", h
);
1820 strout (buf
, len
, len
, printcharfun
);
1823 /* Implement a readable output, e.g.:
1824 #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
1825 /* Always print the size. */
1826 len
= sprintf (buf
, "#s(hash-table size %"pD
"d", ASIZE (h
->next
));
1827 strout (buf
, len
, len
, printcharfun
);
1829 if (!NILP (h
->test
))
1831 strout (" test ", -1, -1, printcharfun
);
1832 print_object (h
->test
, printcharfun
, escapeflag
);
1835 if (!NILP (h
->weak
))
1837 strout (" weakness ", -1, -1, printcharfun
);
1838 print_object (h
->weak
, printcharfun
, escapeflag
);
1841 if (!NILP (h
->rehash_size
))
1843 strout (" rehash-size ", -1, -1, printcharfun
);
1844 print_object (h
->rehash_size
, printcharfun
, escapeflag
);
1847 if (!NILP (h
->rehash_threshold
))
1849 strout (" rehash-threshold ", -1, -1, printcharfun
);
1850 print_object (h
->rehash_threshold
, printcharfun
, escapeflag
);
1853 strout (" data ", -1, -1, printcharfun
);
1855 /* Print the data here as a plist. */
1856 real_size
= HASH_TABLE_SIZE (h
);
1859 /* Don't print more elements than the specified maximum. */
1860 if (NATNUMP (Vprint_length
)
1861 && XFASTINT (Vprint_length
) < size
)
1862 size
= XFASTINT (Vprint_length
);
1865 for (i
= 0; i
< size
; i
++)
1866 if (!NILP (HASH_HASH (h
, i
)))
1868 if (i
) PRINTCHAR (' ');
1869 print_object (HASH_KEY (h
, i
), printcharfun
, escapeflag
);
1871 print_object (HASH_VALUE (h
, i
), printcharfun
, escapeflag
);
1874 if (size
< real_size
)
1875 strout (" ...", 4, 4, printcharfun
);
1881 else if (BUFFERP (obj
))
1883 if (NILP (BVAR (XBUFFER (obj
), name
)))
1884 strout ("#<killed buffer>", -1, -1, printcharfun
);
1885 else if (escapeflag
)
1887 strout ("#<buffer ", -1, -1, printcharfun
);
1888 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1892 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1894 else if (WINDOW_CONFIGURATIONP (obj
))
1896 strout ("#<window-configuration>", -1, -1, printcharfun
);
1898 else if (FRAMEP (obj
))
1901 strout ((FRAME_LIVE_P (XFRAME (obj
))
1902 ? "#<frame " : "#<dead frame "),
1903 -1, -1, printcharfun
);
1904 print_string (XFRAME (obj
)->name
, printcharfun
);
1905 len
= sprintf (buf
, " %p", XFRAME (obj
));
1906 strout (buf
, len
, len
, printcharfun
);
1909 else if (FONTP (obj
))
1913 if (! FONT_OBJECT_P (obj
))
1915 if (FONT_SPEC_P (obj
))
1916 strout ("#<font-spec", -1, -1, printcharfun
);
1918 strout ("#<font-entity", -1, -1, printcharfun
);
1919 for (i
= 0; i
< FONT_SPEC_MAX
; i
++)
1922 if (i
< FONT_WEIGHT_INDEX
|| i
> FONT_WIDTH_INDEX
)
1923 print_object (AREF (obj
, i
), printcharfun
, escapeflag
);
1925 print_object (font_style_symbolic (obj
, i
, 0),
1926 printcharfun
, escapeflag
);
1931 strout ("#<font-object ", -1, -1, printcharfun
);
1932 print_object (AREF (obj
, FONT_NAME_INDEX
), printcharfun
,
1939 ptrdiff_t size
= ASIZE (obj
);
1940 if (COMPILEDP (obj
))
1943 size
&= PSEUDOVECTOR_SIZE_MASK
;
1945 if (CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
))
1947 /* We print a char-table as if it were a vector,
1948 lumping the parent and default slots in with the
1949 character slots. But we add #^ as a prefix. */
1951 /* Make each lowest sub_char_table start a new line.
1952 Otherwise we'll make a line extremely long, which
1953 results in slow redisplay. */
1954 if (SUB_CHAR_TABLE_P (obj
)
1955 && XINT (XSUB_CHAR_TABLE (obj
)->depth
) == 3)
1959 if (SUB_CHAR_TABLE_P (obj
))
1961 size
&= PSEUDOVECTOR_SIZE_MASK
;
1963 if (size
& PSEUDOVECTOR_FLAG
)
1969 register Lisp_Object tem
;
1970 ptrdiff_t real_size
= size
;
1972 /* Don't print more elements than the specified maximum. */
1973 if (NATNUMP (Vprint_length
)
1974 && XFASTINT (Vprint_length
) < size
)
1975 size
= XFASTINT (Vprint_length
);
1977 for (i
= 0; i
< size
; i
++)
1979 if (i
) PRINTCHAR (' ');
1980 tem
= AREF (obj
, i
);
1981 print_object (tem
, printcharfun
, escapeflag
);
1983 if (size
< real_size
)
1984 strout (" ...", 4, 4, printcharfun
);
1991 switch (XMISCTYPE (obj
))
1993 case Lisp_Misc_Marker
:
1994 strout ("#<marker ", -1, -1, printcharfun
);
1995 /* Do you think this is necessary? */
1996 if (XMARKER (obj
)->insertion_type
!= 0)
1997 strout ("(moves after insertion) ", -1, -1, printcharfun
);
1998 if (! XMARKER (obj
)->buffer
)
1999 strout ("in no buffer", -1, -1, printcharfun
);
2002 int len
= sprintf (buf
, "at %"pD
"d", marker_position (obj
));
2003 strout (buf
, len
, len
, printcharfun
);
2004 strout (" in ", -1, -1, printcharfun
);
2005 print_string (BVAR (XMARKER (obj
)->buffer
, name
), printcharfun
);
2010 case Lisp_Misc_Overlay
:
2011 strout ("#<overlay ", -1, -1, printcharfun
);
2012 if (! XMARKER (OVERLAY_START (obj
))->buffer
)
2013 strout ("in no buffer", -1, -1, printcharfun
);
2016 int len
= sprintf (buf
, "from %"pD
"d to %"pD
"d in ",
2017 marker_position (OVERLAY_START (obj
)),
2018 marker_position (OVERLAY_END (obj
)));
2019 strout (buf
, len
, len
, printcharfun
);
2020 print_string (BVAR (XMARKER (OVERLAY_START (obj
))->buffer
, name
),
2026 /* Remaining cases shouldn't happen in normal usage, but let's print
2027 them anyway for the benefit of the debugger. */
2028 case Lisp_Misc_Free
:
2029 strout ("#<misc free cell>", -1, -1, printcharfun
);
2032 case Lisp_Misc_Save_Value
:
2033 strout ("#<save_value ", -1, -1, printcharfun
);
2035 int len
= sprintf (buf
, "ptr=%p int=%"pD
"d",
2036 XSAVE_VALUE (obj
)->pointer
,
2037 XSAVE_VALUE (obj
)->integer
);
2038 strout (buf
, len
, len
, printcharfun
);
2052 /* We're in trouble if this happens!
2053 Probably should just abort () */
2054 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
);
2056 len
= sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2057 else if (VECTORLIKEP (obj
))
2058 len
= sprintf (buf
, "(PVEC 0x%08"pD
"x)", ASIZE (obj
));
2060 len
= sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2061 strout (buf
, len
, len
, printcharfun
);
2062 strout (" Save your buffers immediately and please report this bug>",
2063 -1, -1, printcharfun
);
2071 /* Print a description of INTERVAL using PRINTCHARFUN.
2072 This is part of printing a string that has text properties. */
2075 print_interval (INTERVAL interval
, Lisp_Object printcharfun
)
2077 if (NILP (interval
->plist
))
2080 print_object (make_number (interval
->position
), printcharfun
, 1);
2082 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2085 print_object (interval
->plist
, printcharfun
, 1);
2090 syms_of_print (void)
2092 DEFSYM (Qtemp_buffer_setup_hook
, "temp-buffer-setup-hook");
2094 DEFVAR_LISP ("standard-output", Vstandard_output
,
2095 doc
: /* Output stream `print' uses by default for outputting a character.
2096 This may be any function of one argument.
2097 It may also be a buffer (output is inserted before point)
2098 or a marker (output is inserted and the marker is advanced)
2099 or the symbol t (output appears in the echo area). */);
2100 Vstandard_output
= Qt
;
2101 DEFSYM (Qstandard_output
, "standard-output");
2103 DEFVAR_LISP ("float-output-format", Vfloat_output_format
,
2104 doc
: /* The format descriptor string used to print floats.
2105 This is a %-spec like those accepted by `printf' in C,
2106 but with some restrictions. It must start with the two characters `%.'.
2107 After that comes an integer precision specification,
2108 and then a letter which controls the format.
2109 The letters allowed are `e', `f' and `g'.
2110 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2111 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2112 Use `g' to choose the shorter of those two formats for the number at hand.
2113 The precision in any of these cases is the number of digits following
2114 the decimal point. With `f', a precision of 0 means to omit the
2115 decimal point. 0 is not allowed with `e' or `g'.
2117 A value of nil means to use the shortest notation
2118 that represents the number without losing information. */);
2119 Vfloat_output_format
= Qnil
;
2120 DEFSYM (Qfloat_output_format
, "float-output-format");
2122 DEFVAR_LISP ("print-length", Vprint_length
,
2123 doc
: /* Maximum length of list to print before abbreviating.
2124 A value of nil means no limit. See also `eval-expression-print-length'. */);
2125 Vprint_length
= Qnil
;
2127 DEFVAR_LISP ("print-level", Vprint_level
,
2128 doc
: /* Maximum depth of list nesting to print before abbreviating.
2129 A value of nil means no limit. See also `eval-expression-print-level'. */);
2130 Vprint_level
= Qnil
;
2132 DEFVAR_BOOL ("print-escape-newlines", print_escape_newlines
,
2133 doc
: /* Non-nil means print newlines in strings as `\\n'.
2134 Also print formfeeds as `\\f'. */);
2135 print_escape_newlines
= 0;
2137 DEFVAR_BOOL ("print-escape-nonascii", print_escape_nonascii
,
2138 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2139 \(OOO is the octal representation of the character code.)
2140 Only single-byte characters are affected, and only in `prin1'.
2141 When the output goes in a multibyte buffer, this feature is
2142 enabled regardless of the value of the variable. */);
2143 print_escape_nonascii
= 0;
2145 DEFVAR_BOOL ("print-escape-multibyte", print_escape_multibyte
,
2146 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2147 \(XXXX is the hex representation of the character code.)
2148 This affects only `prin1'. */);
2149 print_escape_multibyte
= 0;
2151 DEFVAR_BOOL ("print-quoted", print_quoted
,
2152 doc
: /* Non-nil means print quoted forms with reader syntax.
2153 I.e., (quote foo) prints as 'foo, (function foo) as #'foo. */);
2156 DEFVAR_LISP ("print-gensym", Vprint_gensym
,
2157 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2158 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2159 When the uninterned symbol appears within a recursive data structure,
2160 and the symbol appears more than once, in addition use the #N# and #N=
2161 constructs as needed, so that multiple references to the same symbol are
2162 shared once again when the text is read back. */);
2163 Vprint_gensym
= Qnil
;
2165 DEFVAR_LISP ("print-circle", Vprint_circle
,
2166 doc
: /* Non-nil means print recursive structures using #N= and #N# syntax.
2167 If nil, printing proceeds recursively and may lead to
2168 `max-lisp-eval-depth' being exceeded or an error may occur:
2169 \"Apparently circular structure being printed.\" Also see
2170 `print-length' and `print-level'.
2171 If non-nil, shared substructures anywhere in the structure are printed
2172 with `#N=' before the first occurrence (in the order of the print
2173 representation) and `#N#' in place of each subsequent occurrence,
2174 where N is a positive decimal integer. */);
2175 Vprint_circle
= Qnil
;
2177 DEFVAR_LISP ("print-continuous-numbering", Vprint_continuous_numbering
,
2178 doc
: /* Non-nil means number continuously across print calls.
2179 This affects the numbers printed for #N= labels and #M# references.
2180 See also `print-circle', `print-gensym', and `print-number-table'.
2181 This variable should not be set with `setq'; bind it with a `let' instead. */);
2182 Vprint_continuous_numbering
= Qnil
;
2184 DEFVAR_LISP ("print-number-table", Vprint_number_table
,
2185 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2186 The Lisp printer uses this vector to detect Lisp objects referenced more
2189 When you bind `print-continuous-numbering' to t, you should probably
2190 also bind `print-number-table' to nil. This ensures that the value of
2191 `print-number-table' can be garbage-collected once the printing is
2192 done. If all elements of `print-number-table' are nil, it means that
2193 the printing done so far has not found any shared structure or objects
2194 that need to be recorded in the table. */);
2195 Vprint_number_table
= Qnil
;
2197 DEFVAR_LISP ("print-charset-text-property", Vprint_charset_text_property
,
2198 doc
: /* A flag to control printing of `charset' text property on printing a string.
2199 The value must be nil, t, or `default'.
2201 If the value is nil, don't print the text property `charset'.
2203 If the value is t, always print the text property `charset'.
2205 If the value is `default', print the text property `charset' only when
2206 the value is different from what is guessed in the current charset
2208 Vprint_charset_text_property
= Qdefault
;
2210 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2211 staticpro (&Vprin1_to_string_buffer
);
2214 defsubr (&Sprin1_to_string
);
2215 defsubr (&Serror_message_string
);
2219 defsubr (&Swrite_char
);
2220 defsubr (&Sexternal_debugging_output
);
2221 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2222 defsubr (&Sredirect_debugging_output
);
2225 DEFSYM (Qexternal_debugging_output
, "external-debugging-output");
2226 DEFSYM (Qprint_escape_newlines
, "print-escape-newlines");
2227 DEFSYM (Qprint_escape_multibyte
, "print-escape-multibyte");
2228 DEFSYM (Qprint_escape_nonascii
, "print-escape-nonascii");
2230 print_prune_charset_plist
= Qnil
;
2231 staticpro (&print_prune_charset_plist
);