1 /* Lisp object printing and output streams.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2011
4 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
27 #include "character.h"
33 #include "dispextern.h"
35 #include "intervals.h"
36 #include "blockinput.h"
37 #include "termhooks.h" /* For struct terminal. */
40 Lisp_Object Qstandard_output
;
42 Lisp_Object Qtemp_buffer_setup_hook
;
44 /* These are used to print like we read. */
46 Lisp_Object Qfloat_output_format
;
55 /* Default to values appropriate for IEEE floating point. */
60 /* Avoid actual stack overflow in print. */
63 /* Level of nesting inside outputting backquote in new style. */
64 int new_backquote_output
;
66 /* Detect most circularities to print finite output. */
67 #define PRINT_CIRCLE 200
68 Lisp_Object being_printed
[PRINT_CIRCLE
];
70 /* When printing into a buffer, first we put the text in this
71 block, then insert it all at once. */
74 /* Size allocated in print_buffer. */
75 EMACS_INT print_buffer_size
;
76 /* Chars stored in print_buffer. */
77 EMACS_INT print_buffer_pos
;
78 /* Bytes stored in print_buffer. */
79 EMACS_INT print_buffer_pos_byte
;
81 Lisp_Object Qprint_escape_newlines
;
82 Lisp_Object Qprint_escape_multibyte
, Qprint_escape_nonascii
;
84 /* Vprint_number_table is a table, that keeps objects that are going to
85 be printed, to allow use of #n= and #n# to express sharing.
86 For any given object, the table can give the following values:
87 t the object will be printed only once.
88 -N the object will be printed several times and will take number N.
89 N the object has been printed so we can refer to it as #N#.
90 print_number_index holds the largest N already used.
91 N has to be striclty larger than 0 since we need to distinguish -N. */
92 int print_number_index
;
93 void print_interval (INTERVAL interval
, Lisp_Object printcharfun
);
95 /* GDB resets this to zero on W32 to disable OutputDebugString calls. */
96 int print_output_debug_flag EXTERNALLY_VISIBLE
= 1;
99 /* Low level output routines for characters and strings */
101 /* Lisp functions to do output using a stream
102 must have the stream in a variable called printcharfun
103 and must start with PRINTPREPARE, end with PRINTFINISH,
104 and use PRINTDECLARE to declare common variables.
105 Use PRINTCHAR to output one character,
106 or call strout to output a block of characters. */
108 #define PRINTDECLARE \
109 struct buffer *old = current_buffer; \
110 EMACS_INT old_point = -1, start_point = -1; \
111 EMACS_INT old_point_byte = -1, start_point_byte = -1; \
112 int specpdl_count = SPECPDL_INDEX (); \
113 int free_print_buffer = 0; \
114 int multibyte = !NILP (current_buffer->enable_multibyte_characters); \
117 #define PRINTPREPARE \
118 original = printcharfun; \
119 if (NILP (printcharfun)) printcharfun = Qt; \
120 if (BUFFERP (printcharfun)) \
122 if (XBUFFER (printcharfun) != current_buffer) \
123 Fset_buffer (printcharfun); \
124 printcharfun = Qnil; \
126 if (MARKERP (printcharfun)) \
128 EMACS_INT marker_pos; \
129 if (! XMARKER (printcharfun)->buffer) \
130 error ("Marker does not point anywhere"); \
131 if (XMARKER (printcharfun)->buffer != current_buffer) \
132 set_buffer_internal (XMARKER (printcharfun)->buffer); \
133 marker_pos = marker_position (printcharfun); \
134 if (marker_pos < BEGV || marker_pos > ZV) \
135 error ("Marker is outside the accessible part of the buffer"); \
137 old_point_byte = PT_BYTE; \
138 SET_PT_BOTH (marker_pos, \
139 marker_byte_position (printcharfun)); \
141 start_point_byte = PT_BYTE; \
142 printcharfun = Qnil; \
144 if (NILP (printcharfun)) \
146 Lisp_Object string; \
147 if (NILP (current_buffer->enable_multibyte_characters) \
148 && ! print_escape_multibyte) \
149 specbind (Qprint_escape_multibyte, Qt); \
150 if (! NILP (current_buffer->enable_multibyte_characters) \
151 && ! print_escape_nonascii) \
152 specbind (Qprint_escape_nonascii, Qt); \
153 if (print_buffer != 0) \
155 string = make_string_from_bytes (print_buffer, \
157 print_buffer_pos_byte); \
158 record_unwind_protect (print_unwind, string); \
162 print_buffer_size = 1000; \
163 print_buffer = (char *) xmalloc (print_buffer_size); \
164 free_print_buffer = 1; \
166 print_buffer_pos = 0; \
167 print_buffer_pos_byte = 0; \
169 if (EQ (printcharfun, Qt) && ! noninteractive) \
170 setup_echo_area_for_printing (multibyte);
172 #define PRINTFINISH \
173 if (NILP (printcharfun)) \
175 if (print_buffer_pos != print_buffer_pos_byte \
176 && NILP (current_buffer->enable_multibyte_characters)) \
178 unsigned char *temp \
179 = (unsigned char *) alloca (print_buffer_pos + 1); \
180 copy_text ((unsigned char *) print_buffer, temp, \
181 print_buffer_pos_byte, 1, 0); \
182 insert_1_both ((char *) temp, print_buffer_pos, \
183 print_buffer_pos, 0, 1, 0); \
186 insert_1_both (print_buffer, print_buffer_pos, \
187 print_buffer_pos_byte, 0, 1, 0); \
188 signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
190 if (free_print_buffer) \
192 xfree (print_buffer); \
195 unbind_to (specpdl_count, Qnil); \
196 if (MARKERP (original)) \
197 set_marker_both (original, Qnil, PT, PT_BYTE); \
198 if (old_point >= 0) \
199 SET_PT_BOTH (old_point + (old_point >= start_point \
200 ? PT - start_point : 0), \
201 old_point_byte + (old_point_byte >= start_point_byte \
202 ? PT_BYTE - start_point_byte : 0)); \
203 if (old != current_buffer) \
204 set_buffer_internal (old);
206 #define PRINTCHAR(ch) printchar (ch, printcharfun)
208 /* This is used to restore the saved contents of print_buffer
209 when there is a recursive call to print. */
212 print_unwind (Lisp_Object saved_text
)
214 memcpy (print_buffer
, SDATA (saved_text
), SCHARS (saved_text
));
219 /* Print character CH using method FUN. FUN nil means print to
220 print_buffer. FUN t means print to echo area or stdout if
221 non-interactive. If FUN is neither nil nor t, call FUN with CH as
225 printchar (unsigned int ch
, Lisp_Object fun
)
227 if (!NILP (fun
) && !EQ (fun
, Qt
))
228 call1 (fun
, make_number (ch
));
231 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
232 int len
= CHAR_STRING (ch
, str
);
238 if (print_buffer_pos_byte
+ len
>= print_buffer_size
)
239 print_buffer
= (char *) xrealloc (print_buffer
,
240 print_buffer_size
*= 2);
241 memcpy (print_buffer
+ print_buffer_pos_byte
, str
, len
);
242 print_buffer_pos
+= 1;
243 print_buffer_pos_byte
+= len
;
245 else if (noninteractive
)
247 fwrite (str
, 1, len
, stdout
);
248 noninteractive_need_newline
= 1;
253 = !NILP (current_buffer
->enable_multibyte_characters
);
255 setup_echo_area_for_printing (multibyte_p
);
257 message_dolog ((char *) str
, len
, 0, multibyte_p
);
263 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
264 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
265 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
266 print_buffer. PRINTCHARFUN t means output to the echo area or to
267 stdout if non-interactive. If neither nil nor t, call Lisp
268 function PRINTCHARFUN for each character printed. MULTIBYTE
269 non-zero means PTR contains multibyte characters.
271 In the case where PRINTCHARFUN is nil, it is safe for PTR to point
272 to data in a Lisp string. Otherwise that is not safe. */
275 strout (const char *ptr
, EMACS_INT size
, EMACS_INT size_byte
,
276 Lisp_Object printcharfun
, int multibyte
)
279 size_byte
= size
= strlen (ptr
);
281 if (NILP (printcharfun
))
283 if (print_buffer_pos_byte
+ size_byte
> print_buffer_size
)
285 print_buffer_size
= print_buffer_size
* 2 + size_byte
;
286 print_buffer
= (char *) xrealloc (print_buffer
,
289 memcpy (print_buffer
+ print_buffer_pos_byte
, ptr
, size_byte
);
290 print_buffer_pos
+= size
;
291 print_buffer_pos_byte
+= size_byte
;
293 else if (noninteractive
&& EQ (printcharfun
, Qt
))
295 fwrite (ptr
, 1, size_byte
, stdout
);
296 noninteractive_need_newline
= 1;
298 else if (EQ (printcharfun
, Qt
))
300 /* Output to echo area. We're trying to avoid a little overhead
301 here, that's the reason we don't call printchar to do the
305 = !NILP (current_buffer
->enable_multibyte_characters
);
307 setup_echo_area_for_printing (multibyte_p
);
308 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
310 if (size
== size_byte
)
312 for (i
= 0; i
< size
; ++i
)
313 insert_char ((unsigned char) *ptr
++);
318 for (i
= 0; i
< size_byte
; i
+= len
)
320 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
328 /* PRINTCHARFUN is a Lisp function. */
331 if (size
== size_byte
)
333 while (i
< size_byte
)
341 while (i
< size_byte
)
343 /* Here, we must convert each multi-byte form to the
344 corresponding character code before handing it to
347 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
356 /* Print the contents of a string STRING using PRINTCHARFUN.
357 It isn't safe to use strout in many cases,
358 because printing one char can relocate. */
361 print_string (Lisp_Object string
, Lisp_Object printcharfun
)
363 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
367 if (print_escape_nonascii
)
368 string
= string_escape_byte8 (string
);
370 if (STRING_MULTIBYTE (string
))
371 chars
= SCHARS (string
);
372 else if (! print_escape_nonascii
373 && (EQ (printcharfun
, Qt
)
374 ? ! NILP (buffer_defaults
.enable_multibyte_characters
)
375 : ! NILP (current_buffer
->enable_multibyte_characters
)))
377 /* If unibyte string STRING contains 8-bit codes, we must
378 convert STRING to a multibyte string containing the same
383 chars
= SBYTES (string
);
384 bytes
= parse_str_to_multibyte (SDATA (string
), chars
);
387 newstr
= make_uninit_multibyte_string (chars
, bytes
);
388 memcpy (SDATA (newstr
), SDATA (string
), chars
);
389 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
394 chars
= SBYTES (string
);
396 if (EQ (printcharfun
, Qt
))
398 /* Output to echo area. */
399 EMACS_INT nbytes
= SBYTES (string
);
402 /* Copy the string contents so that relocation of STRING by
403 GC does not cause trouble. */
406 SAFE_ALLOCA (buffer
, char *, nbytes
);
407 memcpy (buffer
, SDATA (string
), nbytes
);
409 strout (buffer
, chars
, SBYTES (string
),
410 printcharfun
, STRING_MULTIBYTE (string
));
415 /* No need to copy, since output to print_buffer can't GC. */
416 strout (SSDATA (string
),
417 chars
, SBYTES (string
),
418 printcharfun
, STRING_MULTIBYTE (string
));
422 /* Otherwise, string may be relocated by printing one char.
423 So re-fetch the string address for each character. */
425 EMACS_INT size
= SCHARS (string
);
426 EMACS_INT size_byte
= SBYTES (string
);
429 if (size
== size_byte
)
430 for (i
= 0; i
< size
; i
++)
431 PRINTCHAR (SREF (string
, i
));
433 for (i
= 0; i
< size_byte
; )
435 /* Here, we must convert each multi-byte form to the
436 corresponding character code before handing it to PRINTCHAR. */
438 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
, len
);
446 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
447 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
448 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
449 (Lisp_Object character
, Lisp_Object printcharfun
)
453 if (NILP (printcharfun
))
454 printcharfun
= Vstandard_output
;
455 CHECK_NUMBER (character
);
457 PRINTCHAR (XINT (character
));
462 /* Used from outside of print.c to print a block of SIZE
463 single-byte chars at DATA on the default output stream.
464 Do not use this on the contents of a Lisp string. */
467 write_string (const char *data
, int size
)
470 Lisp_Object printcharfun
;
472 printcharfun
= Vstandard_output
;
475 strout (data
, size
, size
, printcharfun
, 0);
479 /* Used to print a block of SIZE single-byte chars at DATA on a
480 specified stream PRINTCHARFUN.
481 Do not use this on the contents of a Lisp string. */
484 write_string_1 (const char *data
, int size
, Lisp_Object printcharfun
)
489 strout (data
, size
, size
, printcharfun
, 0);
495 temp_output_buffer_setup (const char *bufname
)
497 int count
= SPECPDL_INDEX ();
498 register struct buffer
*old
= current_buffer
;
499 register Lisp_Object buf
;
501 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
503 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
505 Fkill_all_local_variables ();
506 delete_all_overlays (current_buffer
);
507 current_buffer
->directory
= old
->directory
;
508 current_buffer
->read_only
= Qnil
;
509 current_buffer
->filename
= Qnil
;
510 current_buffer
->undo_list
= Qt
;
511 eassert (current_buffer
->overlays_before
== NULL
);
512 eassert (current_buffer
->overlays_after
== NULL
);
513 current_buffer
->enable_multibyte_characters
514 = buffer_defaults
.enable_multibyte_characters
;
515 specbind (Qinhibit_read_only
, Qt
);
516 specbind (Qinhibit_modification_hooks
, Qt
);
518 XSETBUFFER (buf
, current_buffer
);
520 Frun_hooks (1, &Qtemp_buffer_setup_hook
);
522 unbind_to (count
, Qnil
);
524 specbind (Qstandard_output
, buf
);
527 /* FIXME: Use Lisp's with-output-to-temp-buffer instead! */
529 internal_with_output_to_temp_buffer (const char *bufname
, Lisp_Object (*function
) (Lisp_Object
), Lisp_Object args
)
531 int count
= SPECPDL_INDEX ();
532 Lisp_Object buf
, val
;
536 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
537 temp_output_buffer_setup (bufname
);
538 buf
= Vstandard_output
;
541 val
= (*function
) (args
);
544 temp_output_buffer_show (buf
);
547 return unbind_to (count
, val
);
550 static void print (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
);
551 static void print_preprocess (Lisp_Object obj
);
552 static void print_preprocess_string (INTERVAL interval
, Lisp_Object arg
);
553 static void print_object (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
);
555 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
556 doc
: /* Output a newline to stream PRINTCHARFUN.
557 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
558 (Lisp_Object printcharfun
)
562 if (NILP (printcharfun
))
563 printcharfun
= Vstandard_output
;
570 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
571 doc
: /* Output the printed representation of OBJECT, any Lisp object.
572 Quoting characters are printed when needed to make output that `read'
573 can handle, whenever this is possible. For complex objects, the behavior
574 is controlled by `print-level' and `print-length', which see.
576 OBJECT is any of the Lisp data types: a number, a string, a symbol,
577 a list, a buffer, a window, a frame, etc.
579 A printed representation of an object is text which describes that object.
581 Optional argument PRINTCHARFUN is the output stream, which can be one
584 - a buffer, in which case output is inserted into that buffer at point;
585 - a marker, in which case output is inserted at marker's position;
586 - a function, in which case that function is called once for each
587 character of OBJECT's printed representation;
588 - a symbol, in which case that symbol's function definition is called; or
589 - t, in which case the output is displayed in the echo area.
591 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
593 (Lisp_Object object
, Lisp_Object printcharfun
)
597 if (NILP (printcharfun
))
598 printcharfun
= Vstandard_output
;
600 print (object
, printcharfun
, 1);
605 /* a buffer which is used to hold output being built by prin1-to-string */
606 Lisp_Object Vprin1_to_string_buffer
;
608 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
609 doc
: /* Return a string containing the printed representation of OBJECT.
610 OBJECT can be any Lisp object. This function outputs quoting characters
611 when necessary to make output that `read' can handle, whenever possible,
612 unless the optional second argument NOESCAPE is non-nil. For complex objects,
613 the behavior is controlled by `print-level' and `print-length', which see.
615 OBJECT is any of the Lisp data types: a number, a string, a symbol,
616 a list, a buffer, a window, a frame, etc.
618 A printed representation of an object is text which describes that object. */)
619 (Lisp_Object object
, Lisp_Object noescape
)
621 Lisp_Object printcharfun
;
622 /* struct gcpro gcpro1, gcpro2; */
623 Lisp_Object save_deactivate_mark
;
624 int count
= SPECPDL_INDEX ();
625 struct buffer
*previous
;
627 specbind (Qinhibit_modification_hooks
, Qt
);
632 /* Save and restore this--we are altering a buffer
633 but we don't want to deactivate the mark just for that.
634 No need for specbind, since errors deactivate the mark. */
635 save_deactivate_mark
= Vdeactivate_mark
;
636 /* GCPRO2 (object, save_deactivate_mark); */
639 printcharfun
= Vprin1_to_string_buffer
;
641 print (object
, printcharfun
, NILP (noescape
));
642 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
646 previous
= current_buffer
;
647 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
648 object
= Fbuffer_string ();
649 if (SBYTES (object
) == SCHARS (object
))
650 STRING_SET_UNIBYTE (object
);
652 /* Note that this won't make prepare_to_modify_buffer call
653 ask-user-about-supersession-threat because this buffer
654 does not visit a file. */
656 set_buffer_internal (previous
);
658 Vdeactivate_mark
= save_deactivate_mark
;
662 return unbind_to (count
, object
);
665 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
666 doc
: /* Output the printed representation of OBJECT, any Lisp object.
667 No quoting characters are used; no delimiters are printed around
668 the contents of strings.
670 OBJECT is any of the Lisp data types: a number, a string, a symbol,
671 a list, a buffer, a window, a frame, etc.
673 A printed representation of an object is text which describes that object.
675 Optional argument PRINTCHARFUN is the output stream, which can be one
678 - a buffer, in which case output is inserted into that buffer at point;
679 - a marker, in which case output is inserted at marker's position;
680 - a function, in which case that function is called once for each
681 character of OBJECT's printed representation;
682 - a symbol, in which case that symbol's function definition is called; or
683 - t, in which case the output is displayed in the echo area.
685 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
687 (Lisp_Object object
, Lisp_Object printcharfun
)
691 if (NILP (printcharfun
))
692 printcharfun
= Vstandard_output
;
694 print (object
, printcharfun
, 0);
699 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
700 doc
: /* Output the printed representation of OBJECT, with newlines around it.
701 Quoting characters are printed when needed to make output that `read'
702 can handle, whenever this is possible. For complex objects, the behavior
703 is controlled by `print-level' and `print-length', which see.
705 OBJECT is any of the Lisp data types: a number, a string, a symbol,
706 a list, a buffer, a window, a frame, etc.
708 A printed representation of an object is text which describes that object.
710 Optional argument PRINTCHARFUN is the output stream, which can be one
713 - a buffer, in which case output is inserted into that buffer at point;
714 - a marker, in which case output is inserted at marker's position;
715 - a function, in which case that function is called once for each
716 character of OBJECT's printed representation;
717 - a symbol, in which case that symbol's function definition is called; or
718 - t, in which case the output is displayed in the echo area.
720 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
722 (Lisp_Object object
, Lisp_Object printcharfun
)
727 if (NILP (printcharfun
))
728 printcharfun
= Vstandard_output
;
732 print (object
, printcharfun
, 1);
739 /* The subroutine object for external-debugging-output is kept here
740 for the convenience of the debugger. */
741 Lisp_Object Qexternal_debugging_output
;
743 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
744 doc
: /* Write CHARACTER to stderr.
745 You can call print while debugging emacs, and pass it this function
746 to make it write to the debugging output. */)
747 (Lisp_Object character
)
749 CHECK_NUMBER (character
);
750 putc ((int) XINT (character
), stderr
);
753 /* Send the output to a debugger (nothing happens if there isn't one). */
754 if (print_output_debug_flag
)
756 char buf
[2] = {(char) XINT (character
), '\0'};
757 OutputDebugString (buf
);
764 /* This function is never called. Its purpose is to prevent
765 print_output_debug_flag from being optimized away. */
768 debug_output_compilation_hack (int x
)
770 print_output_debug_flag
= x
;
773 #if defined (GNU_LINUX)
775 /* This functionality is not vitally important in general, so we rely on
776 non-portable ability to use stderr as lvalue. */
778 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
780 FILE *initial_stderr_stream
= NULL
;
782 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
784 "FDebug output file: \nP",
785 doc
: /* Redirect debugging output (stderr stream) to file FILE.
786 If FILE is nil, reset target to the initial stderr stream.
787 Optional arg APPEND non-nil (interactively, with prefix arg) means
788 append to existing target file. */)
789 (Lisp_Object file
, Lisp_Object append
)
791 if (initial_stderr_stream
!= NULL
)
797 stderr
= initial_stderr_stream
;
798 initial_stderr_stream
= NULL
;
802 file
= Fexpand_file_name (file
, Qnil
);
803 initial_stderr_stream
= stderr
;
804 stderr
= fopen (SDATA (file
), NILP (append
) ? "w" : "a");
807 stderr
= initial_stderr_stream
;
808 initial_stderr_stream
= NULL
;
809 report_file_error ("Cannot open debugging output stream",
815 #endif /* GNU_LINUX */
818 /* This is the interface for debugging printing. */
821 debug_print (Lisp_Object arg
)
823 Fprin1 (arg
, Qexternal_debugging_output
);
824 fprintf (stderr
, "\r\n");
828 safe_debug_print (Lisp_Object arg
)
830 int valid
= valid_lisp_object_p (arg
);
835 fprintf (stderr
, "#<%s_LISP_OBJECT 0x%08lx>\r\n",
836 !valid
? "INVALID" : "SOME",
837 (unsigned long) XHASH (arg
)
842 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
844 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
845 See Info anchor `(elisp)Definition of signal' for some details on how this
846 error message is constructed. */)
849 struct buffer
*old
= current_buffer
;
853 /* If OBJ is (error STRING), just return STRING.
854 That is not only faster, it also avoids the need to allocate
855 space here when the error is due to memory full. */
856 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
857 && CONSP (XCDR (obj
))
858 && STRINGP (XCAR (XCDR (obj
)))
859 && NILP (XCDR (XCDR (obj
))))
860 return XCAR (XCDR (obj
));
862 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
864 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
865 value
= Fbuffer_string ();
869 set_buffer_internal (old
);
875 /* Print an error message for the error DATA onto Lisp output stream
876 STREAM (suitable for the print functions).
877 CONTEXT is a C string describing the context of the error.
878 CALLER is the Lisp function inside which the error was signaled. */
881 print_error_message (Lisp_Object data
, Lisp_Object stream
, const char *context
,
884 Lisp_Object errname
, errmsg
, file_error
, tail
;
889 write_string_1 (context
, -1, stream
);
891 /* If we know from where the error was signaled, show it in
893 if (!NILP (caller
) && SYMBOLP (caller
))
895 Lisp_Object cname
= SYMBOL_NAME (caller
);
896 char *name
= alloca (SBYTES (cname
));
897 memcpy (name
, SDATA (cname
), SBYTES (cname
));
898 message_dolog (name
, SBYTES (cname
), 0, 0);
899 message_dolog (": ", 2, 0, 0);
902 errname
= Fcar (data
);
904 if (EQ (errname
, Qerror
))
909 errmsg
= Fcar (data
);
914 Lisp_Object error_conditions
;
915 errmsg
= Fget (errname
, Qerror_message
);
916 error_conditions
= Fget (errname
, Qerror_conditions
);
917 file_error
= Fmemq (Qfile_error
, error_conditions
);
920 /* Print an error message including the data items. */
922 tail
= Fcdr_safe (data
);
925 /* For file-error, make error message by concatenating
926 all the data items. They are all strings. */
927 if (!NILP (file_error
) && CONSP (tail
))
928 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
930 if (STRINGP (errmsg
))
931 Fprinc (errmsg
, stream
);
933 write_string_1 ("peculiar error", -1, stream
);
935 for (i
= 0; CONSP (tail
); tail
= XCDR (tail
), i
++)
939 write_string_1 (i
? ", " : ": ", 2, stream
);
941 if (!NILP (file_error
) || EQ (errname
, Qend_of_file
))
942 Fprinc (obj
, stream
);
944 Fprin1 (obj
, stream
);
953 * The buffer should be at least as large as the max string size of the
954 * largest float, printed in the biggest notation. This is undoubtedly
955 * 20d float_output_format, with the negative of the C-constant "HUGE"
958 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
960 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
961 * case of -1e307 in 20d float_output_format. What is one to do (short of
962 * re-writing _doprnt to be more sane)?
964 * Given the above, the buffer must be least FLOAT_TO_STRING_BUFSIZE bytes.
968 float_to_string (char *buf
, double data
)
973 /* Check for plus infinity in a way that won't lose
974 if there is no plus infinity. */
975 if (data
== data
/ 2 && data
> 1.0)
977 strcpy (buf
, "1.0e+INF");
980 /* Likewise for minus infinity. */
981 if (data
== data
/ 2 && data
< -1.0)
983 strcpy (buf
, "-1.0e+INF");
986 /* Check for NaN in a way that won't fail if there are no NaNs. */
987 if (! (data
* 0.0 >= 0.0))
989 /* Prepend "-" if the NaN's sign bit is negative.
990 The sign bit of a double is the bit that is 1 in -0.0. */
992 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
994 u_minus_zero
.d
= - 0.0;
995 for (i
= 0; i
< sizeof (double); i
++)
996 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
1002 strcpy (buf
, "0.0e+NaN");
1006 if (NILP (Vfloat_output_format
)
1007 || !STRINGP (Vfloat_output_format
))
1010 /* Generate the fewest number of digits that represent the
1011 floating point value without losing information. */
1012 dtoastr (buf
, FLOAT_TO_STRING_BUFSIZE
, 0, 0, data
);
1014 else /* oink oink */
1016 /* Check that the spec we have is fully valid.
1017 This means not only valid for printf,
1018 but meant for floats, and reasonable. */
1019 cp
= SSDATA (Vfloat_output_format
);
1028 /* Check the width specification. */
1030 if ('0' <= *cp
&& *cp
<= '9')
1034 width
= (width
* 10) + (*cp
++ - '0');
1035 while (*cp
>= '0' && *cp
<= '9');
1037 /* A precision of zero is valid only for %f. */
1039 || (width
== 0 && *cp
!= 'f'))
1043 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1049 sprintf (buf
, SSDATA (Vfloat_output_format
), data
);
1052 /* Make sure there is a decimal point with digit after, or an
1053 exponent, so that the value is readable as a float. But don't do
1054 this with "%.0f"; it's valid for that not to produce a decimal
1055 point. Note that width can be 0 only for %.0f. */
1058 for (cp
= buf
; *cp
; cp
++)
1059 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1062 if (*cp
== '.' && cp
[1] == 0)
1079 print (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
)
1081 new_backquote_output
= 0;
1083 /* Reset print_number_index and Vprint_number_table only when
1084 the variable Vprint_continuous_numbering is nil. Otherwise,
1085 the values of these variables will be kept between several
1087 if (NILP (Vprint_continuous_numbering
)
1088 || NILP (Vprint_number_table
))
1090 print_number_index
= 0;
1091 Vprint_number_table
= Qnil
;
1094 /* Construct Vprint_number_table for print-gensym and print-circle. */
1095 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1097 /* Construct Vprint_number_table.
1098 This increments print_number_index for the objects added. */
1100 print_preprocess (obj
);
1102 if (HASH_TABLE_P (Vprint_number_table
))
1103 { /* Remove unnecessary objects, which appear only once in OBJ;
1104 that is, whose status is Qt.
1105 Maybe a better way to do that is to copy elements to
1106 a new hash table. */
1107 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vprint_number_table
);
1110 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
1111 if (!NILP (HASH_HASH (h
, i
))
1112 && EQ (HASH_VALUE (h
, i
), Qt
))
1113 Fremhash (HASH_KEY (h
, i
), Vprint_number_table
);
1118 print_object (obj
, printcharfun
, escapeflag
);
1121 /* Construct Vprint_number_table according to the structure of OBJ.
1122 OBJ itself and all its elements will be added to Vprint_number_table
1123 recursively if it is a list, vector, compiled function, char-table,
1124 string (its text properties will be traced), or a symbol that has
1125 no obarray (this is for the print-gensym feature).
1126 The status fields of Vprint_number_table mean whether each object appears
1127 more than once in OBJ: Qnil at the first time, and Qt after that . */
1129 print_preprocess (Lisp_Object obj
)
1134 Lisp_Object halftail
;
1136 /* Give up if we go so deep that print_object will get an error. */
1137 /* See similar code in print_object. */
1138 if (print_depth
>= PRINT_CIRCLE
)
1139 error ("Apparently circular structure being printed");
1141 /* Avoid infinite recursion for circular nested structure
1142 in the case where Vprint_circle is nil. */
1143 if (NILP (Vprint_circle
))
1145 for (i
= 0; i
< print_depth
; i
++)
1146 if (EQ (obj
, being_printed
[i
]))
1148 being_printed
[print_depth
] = obj
;
1155 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1156 || FUNVECP (obj
) || CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
)
1157 || HASH_TABLE_P (obj
)
1158 || (! NILP (Vprint_gensym
)
1160 && !SYMBOL_INTERNED_P (obj
)))
1162 if (!HASH_TABLE_P (Vprint_number_table
))
1164 Lisp_Object args
[2];
1167 Vprint_number_table
= Fmake_hash_table (2, args
);
1170 /* In case print-circle is nil and print-gensym is t,
1171 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1172 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1174 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1176 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1177 always print the gensym with a number. This is a special for
1178 the lisp function byte-compile-output-docform. */
1179 || (!NILP (Vprint_continuous_numbering
)
1181 && !SYMBOL_INTERNED_P (obj
)))
1182 { /* OBJ appears more than once. Let's remember that. */
1183 if (!INTEGERP (num
))
1185 print_number_index
++;
1186 /* Negative number indicates it hasn't been printed yet. */
1187 Fputhash (obj
, make_number (- print_number_index
),
1188 Vprint_number_table
);
1194 /* OBJ is not yet recorded. Let's add to the table. */
1195 Fputhash (obj
, Qt
, Vprint_number_table
);
1198 switch (XTYPE (obj
))
1201 /* A string may have text properties, which can be circular. */
1202 traverse_intervals_noorder (STRING_INTERVALS (obj
),
1203 print_preprocess_string
, Qnil
);
1207 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1208 just as in print_object. */
1209 if (loop_count
&& EQ (obj
, halftail
))
1211 print_preprocess (XCAR (obj
));
1214 if (!(loop_count
& 1))
1215 halftail
= XCDR (halftail
);
1218 case Lisp_Vectorlike
:
1219 size
= XVECTOR (obj
)->size
;
1220 if (size
& PSEUDOVECTOR_FLAG
)
1221 size
&= PSEUDOVECTOR_SIZE_MASK
;
1222 for (i
= 0; i
< size
; i
++)
1223 print_preprocess (XVECTOR (obj
)->contents
[i
]);
1224 if (HASH_TABLE_P (obj
))
1225 { /* For hash tables, the key_and_value slot is past
1226 `size' because it needs to be marked specially in case
1227 the table is weak. */
1228 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1229 print_preprocess (h
->key_and_value
);
1241 print_preprocess_string (INTERVAL interval
, Lisp_Object arg
)
1243 print_preprocess (interval
->plist
);
1246 static void print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
);
1248 #define PRINT_STRING_NON_CHARSET_FOUND 1
1249 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1251 /* Bitwise or of the above macros. */
1252 static int print_check_string_result
;
1255 print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
)
1259 if (NILP (interval
->plist
)
1260 || (print_check_string_result
== (PRINT_STRING_NON_CHARSET_FOUND
1261 | PRINT_STRING_UNSAFE_CHARSET_FOUND
)))
1263 for (val
= interval
->plist
; CONSP (val
) && ! EQ (XCAR (val
), Qcharset
);
1264 val
= XCDR (XCDR (val
)));
1267 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1270 if (! (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
))
1272 if (! EQ (val
, interval
->plist
)
1273 || CONSP (XCDR (XCDR (val
))))
1274 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1276 if (NILP (Vprint_charset_text_property
)
1277 || ! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1280 EMACS_INT charpos
= interval
->position
;
1281 EMACS_INT bytepos
= string_char_to_byte (string
, charpos
);
1282 Lisp_Object charset
;
1284 charset
= XCAR (XCDR (val
));
1285 for (i
= 0; i
< LENGTH (interval
); i
++)
1287 FETCH_STRING_CHAR_ADVANCE (c
, string
, charpos
, bytepos
);
1288 if (! ASCII_CHAR_P (c
)
1289 && ! EQ (CHARSET_NAME (CHAR_CHARSET (c
)), charset
))
1291 print_check_string_result
|= PRINT_STRING_UNSAFE_CHARSET_FOUND
;
1298 /* The value is (charset . nil). */
1299 static Lisp_Object print_prune_charset_plist
;
1302 print_prune_string_charset (Lisp_Object string
)
1304 print_check_string_result
= 0;
1305 traverse_intervals (STRING_INTERVALS (string
), 0,
1306 print_check_string_charset_prop
, string
);
1307 if (! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1309 string
= Fcopy_sequence (string
);
1310 if (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
)
1312 if (NILP (print_prune_charset_plist
))
1313 print_prune_charset_plist
= Fcons (Qcharset
, Qnil
);
1314 Fremove_text_properties (make_number (0),
1315 make_number (SCHARS (string
)),
1316 print_prune_charset_plist
, string
);
1319 Fset_text_properties (make_number (0), make_number (SCHARS (string
)),
1326 print_object (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
)
1332 /* See similar code in print_preprocess. */
1333 if (print_depth
>= PRINT_CIRCLE
)
1334 error ("Apparently circular structure being printed");
1336 /* Detect circularities and truncate them. */
1337 if (STRINGP (obj
) || CONSP (obj
) || VECTORP (obj
)
1338 || FUNVECP (obj
) || CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
)
1339 || HASH_TABLE_P (obj
)
1340 || (! NILP (Vprint_gensym
)
1342 && !SYMBOL_INTERNED_P (obj
)))
1344 if (NILP (Vprint_circle
) && NILP (Vprint_gensym
))
1346 /* Simple but incomplete way. */
1348 for (i
= 0; i
< print_depth
; i
++)
1349 if (EQ (obj
, being_printed
[i
]))
1351 sprintf (buf
, "#%d", i
);
1352 strout (buf
, -1, -1, printcharfun
, 0);
1355 being_printed
[print_depth
] = obj
;
1359 /* With the print-circle feature. */
1360 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1365 { /* Add a prefix #n= if OBJ has not yet been printed;
1366 that is, its status field is nil. */
1367 sprintf (buf
, "#%d=", -n
);
1368 strout (buf
, -1, -1, printcharfun
, 0);
1369 /* OBJ is going to be printed. Remember that fact. */
1370 Fputhash (obj
, make_number (- n
), Vprint_number_table
);
1374 /* Just print #n# if OBJ has already been printed. */
1375 sprintf (buf
, "#%d#", n
);
1376 strout (buf
, -1, -1, printcharfun
, 0);
1385 switch (XTYPE (obj
))
1388 if (sizeof (int) == sizeof (EMACS_INT
))
1389 sprintf (buf
, "%d", (int) XINT (obj
));
1390 else if (sizeof (long) == sizeof (EMACS_INT
))
1391 sprintf (buf
, "%ld", (long) XINT (obj
));
1394 strout (buf
, -1, -1, printcharfun
, 0);
1399 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
1401 float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1402 strout (pigbuf
, -1, -1, printcharfun
, 0);
1408 print_string (obj
, printcharfun
);
1411 register EMACS_INT i
, i_byte
;
1412 struct gcpro gcpro1
;
1414 EMACS_INT size_byte
;
1415 /* 1 means we must ensure that the next character we output
1416 cannot be taken as part of a hex character escape. */
1417 int need_nonhex
= 0;
1418 int multibyte
= STRING_MULTIBYTE (obj
);
1422 if (! EQ (Vprint_charset_text_property
, Qt
))
1423 obj
= print_prune_string_charset (obj
);
1425 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1433 size_byte
= SBYTES (obj
);
1435 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1437 /* Here, we must convert each multi-byte form to the
1438 corresponding character code before handing it to PRINTCHAR. */
1444 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
, len
);
1452 if (c
== '\n' && print_escape_newlines
)
1457 else if (c
== '\f' && print_escape_newlines
)
1463 && (CHAR_BYTE8_P (c
)
1464 || (! ASCII_CHAR_P (c
) && print_escape_multibyte
)))
1466 /* When multibyte is disabled,
1467 print multibyte string chars using hex escapes.
1468 For a char code that could be in a unibyte string,
1469 when found in a multibyte string, always use a hex escape
1470 so it reads back as multibyte. */
1473 if (CHAR_BYTE8_P (c
))
1474 sprintf (outbuf
, "\\%03o", CHAR_TO_BYTE8 (c
));
1477 sprintf (outbuf
, "\\x%04x", c
);
1480 strout (outbuf
, -1, -1, printcharfun
, 0);
1482 else if (! multibyte
1483 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1484 && print_escape_nonascii
)
1486 /* When printing in a multibyte buffer
1487 or when explicitly requested,
1488 print single-byte non-ASCII string chars
1489 using octal escapes. */
1491 sprintf (outbuf
, "\\%03o", c
);
1492 strout (outbuf
, -1, -1, printcharfun
, 0);
1496 /* If we just had a hex escape, and this character
1497 could be taken as part of it,
1498 output `\ ' to prevent that. */
1502 if ((c
>= 'a' && c
<= 'f')
1503 || (c
>= 'A' && c
<= 'F')
1504 || (c
>= '0' && c
<= '9'))
1505 strout ("\\ ", -1, -1, printcharfun
, 0);
1508 if (c
== '\"' || c
== '\\')
1515 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1517 traverse_intervals (STRING_INTERVALS (obj
),
1518 0, print_interval
, printcharfun
);
1528 register int confusing
;
1529 register unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1530 register unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1533 EMACS_INT size_byte
;
1536 name
= SYMBOL_NAME (obj
);
1538 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1541 /* If symbol name begins with a digit, and ends with a digit,
1542 and contains nothing but digits and `e', it could be treated
1543 as a number. So set CONFUSING.
1545 Symbols that contain periods could also be taken as numbers,
1546 but periods are always escaped, so we don't have to worry
1548 else if (*p
>= '0' && *p
<= '9'
1549 && end
[-1] >= '0' && end
[-1] <= '9')
1551 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1552 /* Needed for \2e10. */
1553 || *p
== 'e' || *p
== 'E'))
1555 confusing
= (end
== p
);
1560 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1566 size_byte
= SBYTES (name
);
1568 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1570 /* Here, we must convert each multi-byte form to the
1571 corresponding character code before handing it to PRINTCHAR. */
1572 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1577 if (c
== '\"' || c
== '\\' || c
== '\''
1578 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1579 || c
== ',' || c
=='.' || c
== '`'
1580 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1582 PRINTCHAR ('\\'), confusing
= 0;
1590 /* If deeper than spec'd depth, print placeholder. */
1591 if (INTEGERP (Vprint_level
)
1592 && print_depth
> XINT (Vprint_level
))
1593 strout ("...", -1, -1, printcharfun
, 0);
1594 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1595 && (EQ (XCAR (obj
), Qquote
)))
1598 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1600 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1601 && (EQ (XCAR (obj
), Qfunction
)))
1605 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1607 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1608 && ((EQ (XCAR (obj
), Qbackquote
))))
1610 print_object (XCAR (obj
), printcharfun
, 0);
1611 new_backquote_output
++;
1612 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1613 new_backquote_output
--;
1615 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1616 && new_backquote_output
1617 && ((EQ (XCAR (obj
), Qbackquote
)
1618 || EQ (XCAR (obj
), Qcomma
)
1619 || EQ (XCAR (obj
), Qcomma_at
)
1620 || EQ (XCAR (obj
), Qcomma_dot
))))
1622 print_object (XCAR (obj
), printcharfun
, 0);
1623 new_backquote_output
--;
1624 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1625 new_backquote_output
++;
1631 /* If the first element is a backquote form,
1632 print it old-style so it won't be misunderstood. */
1633 if (print_quoted
&& CONSP (XCAR (obj
))
1634 && CONSP (XCDR (XCAR (obj
)))
1635 && NILP (XCDR (XCDR (XCAR (obj
))))
1636 && EQ (XCAR (XCAR (obj
)), Qbackquote
))
1642 print_object (Qbackquote
, printcharfun
, 0);
1645 print_object (XCAR (XCDR (tem
)), printcharfun
, 0);
1652 EMACS_INT print_length
;
1654 Lisp_Object halftail
= obj
;
1656 /* Negative values of print-length are invalid in CL.
1657 Treat them like nil, as CMUCL does. */
1658 if (NATNUMP (Vprint_length
))
1659 print_length
= XFASTINT (Vprint_length
);
1666 /* Detect circular list. */
1667 if (NILP (Vprint_circle
))
1669 /* Simple but imcomplete way. */
1670 if (i
!= 0 && EQ (obj
, halftail
))
1672 sprintf (buf
, " . #%d", i
/ 2);
1673 strout (buf
, -1, -1, printcharfun
, 0);
1679 /* With the print-circle feature. */
1682 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1685 strout (" . ", 3, 3, printcharfun
, 0);
1686 print_object (obj
, printcharfun
, escapeflag
);
1695 if (print_length
&& i
> print_length
)
1697 strout ("...", 3, 3, printcharfun
, 0);
1701 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1705 halftail
= XCDR (halftail
);
1709 /* OBJ non-nil here means it's the end of a dotted list. */
1712 strout (" . ", 3, 3, printcharfun
, 0);
1713 print_object (obj
, printcharfun
, escapeflag
);
1721 case Lisp_Vectorlike
:
1726 strout ("#<process ", -1, -1, printcharfun
, 0);
1727 print_string (XPROCESS (obj
)->name
, printcharfun
);
1731 print_string (XPROCESS (obj
)->name
, printcharfun
);
1733 else if (BOOL_VECTOR_P (obj
))
1736 register unsigned char c
;
1737 struct gcpro gcpro1
;
1738 EMACS_INT size_in_chars
1739 = ((XBOOL_VECTOR (obj
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
1740 / BOOL_VECTOR_BITS_PER_CHAR
);
1746 sprintf (buf
, "%ld", (long) XBOOL_VECTOR (obj
)->size
);
1747 strout (buf
, -1, -1, printcharfun
, 0);
1750 /* Don't print more characters than the specified maximum.
1751 Negative values of print-length are invalid. Treat them
1752 like a print-length of nil. */
1753 if (NATNUMP (Vprint_length
)
1754 && XFASTINT (Vprint_length
) < size_in_chars
)
1755 size_in_chars
= XFASTINT (Vprint_length
);
1757 for (i
= 0; i
< size_in_chars
; i
++)
1760 c
= XBOOL_VECTOR (obj
)->data
[i
];
1761 if (c
== '\n' && print_escape_newlines
)
1766 else if (c
== '\f' && print_escape_newlines
)
1771 else if (c
> '\177')
1773 /* Use octal escapes to avoid encoding issues. */
1775 PRINTCHAR ('0' + ((c
>> 6) & 3));
1776 PRINTCHAR ('0' + ((c
>> 3) & 7));
1777 PRINTCHAR ('0' + (c
& 7));
1781 if (c
== '\"' || c
== '\\')
1790 else if (SUBRP (obj
))
1792 strout ("#<subr ", -1, -1, printcharfun
, 0);
1793 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
, 0);
1796 else if (WINDOWP (obj
))
1798 strout ("#<window ", -1, -1, printcharfun
, 0);
1799 sprintf (buf
, "%ld", (long) XFASTINT (XWINDOW (obj
)->sequence_number
));
1800 strout (buf
, -1, -1, printcharfun
, 0);
1801 if (!NILP (XWINDOW (obj
)->buffer
))
1803 strout (" on ", -1, -1, printcharfun
, 0);
1804 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1808 else if (TERMINALP (obj
))
1810 struct terminal
*t
= XTERMINAL (obj
);
1811 strout ("#<terminal ", -1, -1, printcharfun
, 0);
1812 sprintf (buf
, "%d", t
->id
);
1813 strout (buf
, -1, -1, printcharfun
, 0);
1816 strout (" on ", -1, -1, printcharfun
, 0);
1817 strout (t
->name
, -1, -1, printcharfun
, 0);
1821 else if (HASH_TABLE_P (obj
))
1823 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1825 EMACS_INT real_size
, size
;
1827 strout ("#<hash-table", -1, -1, printcharfun
, 0);
1828 if (SYMBOLP (h
->test
))
1832 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
, 0);
1834 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
, 0);
1836 sprintf (buf
, "%ld/%ld", (long) h
->count
,
1837 (long) XVECTOR (h
->next
)->size
);
1838 strout (buf
, -1, -1, printcharfun
, 0);
1840 sprintf (buf
, " 0x%lx", (unsigned long) h
);
1841 strout (buf
, -1, -1, printcharfun
, 0);
1844 /* Implement a readable output, e.g.:
1845 #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
1846 /* Always print the size. */
1847 sprintf (buf
, "#s(hash-table size %ld",
1848 (long) XVECTOR (h
->next
)->size
);
1849 strout (buf
, -1, -1, printcharfun
, 0);
1851 if (!NILP (h
->test
))
1853 strout (" test ", -1, -1, printcharfun
, 0);
1854 print_object (h
->test
, printcharfun
, 0);
1857 if (!NILP (h
->weak
))
1859 strout (" weakness ", -1, -1, printcharfun
, 0);
1860 print_object (h
->weak
, printcharfun
, 0);
1863 if (!NILP (h
->rehash_size
))
1865 strout (" rehash-size ", -1, -1, printcharfun
, 0);
1866 print_object (h
->rehash_size
, printcharfun
, 0);
1869 if (!NILP (h
->rehash_threshold
))
1871 strout (" rehash-threshold ", -1, -1, printcharfun
, 0);
1872 print_object (h
->rehash_threshold
, printcharfun
, 0);
1875 strout (" data ", -1, -1, printcharfun
, 0);
1877 /* Print the data here as a plist. */
1878 real_size
= HASH_TABLE_SIZE (h
);
1881 /* Don't print more elements than the specified maximum. */
1882 if (NATNUMP (Vprint_length
)
1883 && XFASTINT (Vprint_length
) < size
)
1884 size
= XFASTINT (Vprint_length
);
1887 for (i
= 0; i
< size
; i
++)
1888 if (!NILP (HASH_HASH (h
, i
)))
1890 if (i
) PRINTCHAR (' ');
1891 print_object (HASH_KEY (h
, i
), printcharfun
, 1);
1893 print_object (HASH_VALUE (h
, i
), printcharfun
, 1);
1896 if (size
< real_size
)
1897 strout (" ...", 4, 4, printcharfun
, 0);
1903 else if (BUFFERP (obj
))
1905 if (NILP (XBUFFER (obj
)->name
))
1906 strout ("#<killed buffer>", -1, -1, printcharfun
, 0);
1907 else if (escapeflag
)
1909 strout ("#<buffer ", -1, -1, printcharfun
, 0);
1910 print_string (XBUFFER (obj
)->name
, printcharfun
);
1914 print_string (XBUFFER (obj
)->name
, printcharfun
);
1916 else if (WINDOW_CONFIGURATIONP (obj
))
1918 strout ("#<window-configuration>", -1, -1, printcharfun
, 0);
1920 else if (FRAMEP (obj
))
1922 strout ((FRAME_LIVE_P (XFRAME (obj
))
1923 ? "#<frame " : "#<dead frame "),
1924 -1, -1, printcharfun
, 0);
1925 print_string (XFRAME (obj
)->name
, printcharfun
);
1926 sprintf (buf
, " 0x%lx", (unsigned long) (XFRAME (obj
)));
1927 strout (buf
, -1, -1, printcharfun
, 0);
1930 else if (FONTP (obj
))
1934 if (! FONT_OBJECT_P (obj
))
1936 if (FONT_SPEC_P (obj
))
1937 strout ("#<font-spec", -1, -1, printcharfun
, 0);
1939 strout ("#<font-entity", -1, -1, printcharfun
, 0);
1940 for (i
= 0; i
< FONT_SPEC_MAX
; i
++)
1943 if (i
< FONT_WEIGHT_INDEX
|| i
> FONT_WIDTH_INDEX
)
1944 print_object (AREF (obj
, i
), printcharfun
, escapeflag
);
1946 print_object (font_style_symbolic (obj
, i
, 0),
1947 printcharfun
, escapeflag
);
1952 strout ("#<font-object ", -1, -1, printcharfun
, 0);
1953 print_object (AREF (obj
, FONT_NAME_INDEX
), printcharfun
,
1960 EMACS_INT size
= XVECTOR (obj
)->size
;
1964 size
&= PSEUDOVECTOR_SIZE_MASK
;
1966 if (CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
))
1968 /* We print a char-table as if it were a vector,
1969 lumping the parent and default slots in with the
1970 character slots. But we add #^ as a prefix. */
1972 /* Make each lowest sub_char_table start a new line.
1973 Otherwise we'll make a line extremely long, which
1974 results in slow redisplay. */
1975 if (SUB_CHAR_TABLE_P (obj
)
1976 && XINT (XSUB_CHAR_TABLE (obj
)->depth
) == 3)
1980 if (SUB_CHAR_TABLE_P (obj
))
1982 size
&= PSEUDOVECTOR_SIZE_MASK
;
1984 if (size
& PSEUDOVECTOR_FLAG
)
1990 register Lisp_Object tem
;
1991 EMACS_INT real_size
= size
;
1993 /* Don't print more elements than the specified maximum. */
1994 if (NATNUMP (Vprint_length
)
1995 && XFASTINT (Vprint_length
) < size
)
1996 size
= XFASTINT (Vprint_length
);
1998 for (i
= 0; i
< size
; i
++)
2000 if (i
) PRINTCHAR (' ');
2001 tem
= XVECTOR (obj
)->contents
[i
];
2002 print_object (tem
, printcharfun
, escapeflag
);
2004 if (size
< real_size
)
2005 strout (" ...", 4, 4, printcharfun
, 0);
2012 switch (XMISCTYPE (obj
))
2014 case Lisp_Misc_Marker
:
2015 strout ("#<marker ", -1, -1, printcharfun
, 0);
2016 /* Do you think this is necessary? */
2017 if (XMARKER (obj
)->insertion_type
!= 0)
2018 strout ("(moves after insertion) ", -1, -1, printcharfun
, 0);
2019 if (! XMARKER (obj
)->buffer
)
2020 strout ("in no buffer", -1, -1, printcharfun
, 0);
2023 sprintf (buf
, "at %ld", (long)marker_position (obj
));
2024 strout (buf
, -1, -1, printcharfun
, 0);
2025 strout (" in ", -1, -1, printcharfun
, 0);
2026 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
2031 case Lisp_Misc_Overlay
:
2032 strout ("#<overlay ", -1, -1, printcharfun
, 0);
2033 if (! XMARKER (OVERLAY_START (obj
))->buffer
)
2034 strout ("in no buffer", -1, -1, printcharfun
, 0);
2037 sprintf (buf
, "from %ld to %ld in ",
2038 (long)marker_position (OVERLAY_START (obj
)),
2039 (long)marker_position (OVERLAY_END (obj
)));
2040 strout (buf
, -1, -1, printcharfun
, 0);
2041 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
2047 /* Remaining cases shouldn't happen in normal usage, but let's print
2048 them anyway for the benefit of the debugger. */
2049 case Lisp_Misc_Free
:
2050 strout ("#<misc free cell>", -1, -1, printcharfun
, 0);
2053 case Lisp_Misc_Save_Value
:
2054 strout ("#<save_value ", -1, -1, printcharfun
, 0);
2055 sprintf(buf
, "ptr=0x%08lx int=%d",
2056 (unsigned long) XSAVE_VALUE (obj
)->pointer
,
2057 XSAVE_VALUE (obj
)->integer
);
2058 strout (buf
, -1, -1, printcharfun
, 0);
2070 /* We're in trouble if this happens!
2071 Probably should just abort () */
2072 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
, 0);
2074 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2075 else if (VECTORLIKEP (obj
))
2076 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
2078 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2079 strout (buf
, -1, -1, printcharfun
, 0);
2080 strout (" Save your buffers immediately and please report this bug>",
2081 -1, -1, printcharfun
, 0);
2089 /* Print a description of INTERVAL using PRINTCHARFUN.
2090 This is part of printing a string that has text properties. */
2093 print_interval (INTERVAL interval
, Lisp_Object printcharfun
)
2095 if (NILP (interval
->plist
))
2098 print_object (make_number (interval
->position
), printcharfun
, 1);
2100 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2103 print_object (interval
->plist
, printcharfun
, 1);
2108 syms_of_print (void)
2110 Qtemp_buffer_setup_hook
= intern_c_string ("temp-buffer-setup-hook");
2111 staticpro (&Qtemp_buffer_setup_hook
);
2113 DEFVAR_LISP ("standard-output", Vstandard_output
,
2114 doc
: /* Output stream `print' uses by default for outputting a character.
2115 This may be any function of one argument.
2116 It may also be a buffer (output is inserted before point)
2117 or a marker (output is inserted and the marker is advanced)
2118 or the symbol t (output appears in the echo area). */);
2119 Vstandard_output
= Qt
;
2120 Qstandard_output
= intern_c_string ("standard-output");
2121 staticpro (&Qstandard_output
);
2123 DEFVAR_LISP ("float-output-format", Vfloat_output_format
,
2124 doc
: /* The format descriptor string used to print floats.
2125 This is a %-spec like those accepted by `printf' in C,
2126 but with some restrictions. It must start with the two characters `%.'.
2127 After that comes an integer precision specification,
2128 and then a letter which controls the format.
2129 The letters allowed are `e', `f' and `g'.
2130 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2131 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2132 Use `g' to choose the shorter of those two formats for the number at hand.
2133 The precision in any of these cases is the number of digits following
2134 the decimal point. With `f', a precision of 0 means to omit the
2135 decimal point. 0 is not allowed with `e' or `g'.
2137 A value of nil means to use the shortest notation
2138 that represents the number without losing information. */);
2139 Vfloat_output_format
= Qnil
;
2140 Qfloat_output_format
= intern_c_string ("float-output-format");
2141 staticpro (&Qfloat_output_format
);
2143 DEFVAR_LISP ("print-length", Vprint_length
,
2144 doc
: /* Maximum length of list to print before abbreviating.
2145 A value of nil means no limit. See also `eval-expression-print-length'. */);
2146 Vprint_length
= Qnil
;
2148 DEFVAR_LISP ("print-level", Vprint_level
,
2149 doc
: /* Maximum depth of list nesting to print before abbreviating.
2150 A value of nil means no limit. See also `eval-expression-print-level'. */);
2151 Vprint_level
= Qnil
;
2153 DEFVAR_BOOL ("print-escape-newlines", print_escape_newlines
,
2154 doc
: /* Non-nil means print newlines in strings as `\\n'.
2155 Also print formfeeds as `\\f'. */);
2156 print_escape_newlines
= 0;
2158 DEFVAR_BOOL ("print-escape-nonascii", print_escape_nonascii
,
2159 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2160 \(OOO is the octal representation of the character code.)
2161 Only single-byte characters are affected, and only in `prin1'.
2162 When the output goes in a multibyte buffer, this feature is
2163 enabled regardless of the value of the variable. */);
2164 print_escape_nonascii
= 0;
2166 DEFVAR_BOOL ("print-escape-multibyte", print_escape_multibyte
,
2167 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2168 \(XXXX is the hex representation of the character code.)
2169 This affects only `prin1'. */);
2170 print_escape_multibyte
= 0;
2172 DEFVAR_BOOL ("print-quoted", print_quoted
,
2173 doc
: /* Non-nil means print quoted forms with reader syntax.
2174 I.e., (quote foo) prints as 'foo, (function foo) as #'foo. */);
2177 DEFVAR_LISP ("print-gensym", Vprint_gensym
,
2178 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2179 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2180 When the uninterned symbol appears within a recursive data structure,
2181 and the symbol appears more than once, in addition use the #N# and #N=
2182 constructs as needed, so that multiple references to the same symbol are
2183 shared once again when the text is read back. */);
2184 Vprint_gensym
= Qnil
;
2186 DEFVAR_LISP ("print-circle", Vprint_circle
,
2187 doc
: /* *Non-nil means print recursive structures using #N= and #N# syntax.
2188 If nil, printing proceeds recursively and may lead to
2189 `max-lisp-eval-depth' being exceeded or an error may occur:
2190 \"Apparently circular structure being printed.\" Also see
2191 `print-length' and `print-level'.
2192 If non-nil, shared substructures anywhere in the structure are printed
2193 with `#N=' before the first occurrence (in the order of the print
2194 representation) and `#N#' in place of each subsequent occurrence,
2195 where N is a positive decimal integer. */);
2196 Vprint_circle
= Qnil
;
2198 DEFVAR_LISP ("print-continuous-numbering", Vprint_continuous_numbering
,
2199 doc
: /* *Non-nil means number continuously across print calls.
2200 This affects the numbers printed for #N= labels and #M# references.
2201 See also `print-circle', `print-gensym', and `print-number-table'.
2202 This variable should not be set with `setq'; bind it with a `let' instead. */);
2203 Vprint_continuous_numbering
= Qnil
;
2205 DEFVAR_LISP ("print-number-table", Vprint_number_table
,
2206 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2207 The Lisp printer uses this vector to detect Lisp objects referenced more
2210 When you bind `print-continuous-numbering' to t, you should probably
2211 also bind `print-number-table' to nil. This ensures that the value of
2212 `print-number-table' can be garbage-collected once the printing is
2213 done. If all elements of `print-number-table' are nil, it means that
2214 the printing done so far has not found any shared structure or objects
2215 that need to be recorded in the table. */);
2216 Vprint_number_table
= Qnil
;
2218 DEFVAR_LISP ("print-charset-text-property", Vprint_charset_text_property
,
2219 doc
: /* A flag to control printing of `charset' text property on printing a string.
2220 The value must be nil, t, or `default'.
2222 If the value is nil, don't print the text property `charset'.
2224 If the value is t, always print the text property `charset'.
2226 If the value is `default', print the text property `charset' only when
2227 the value is different from what is guessed in the current charset
2229 Vprint_charset_text_property
= Qdefault
;
2231 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2232 staticpro (&Vprin1_to_string_buffer
);
2235 defsubr (&Sprin1_to_string
);
2236 defsubr (&Serror_message_string
);
2240 defsubr (&Swrite_char
);
2241 defsubr (&Sexternal_debugging_output
);
2242 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2243 defsubr (&Sredirect_debugging_output
);
2246 Qexternal_debugging_output
= intern_c_string ("external-debugging-output");
2247 staticpro (&Qexternal_debugging_output
);
2249 Qprint_escape_newlines
= intern_c_string ("print-escape-newlines");
2250 staticpro (&Qprint_escape_newlines
);
2252 Qprint_escape_multibyte
= intern_c_string ("print-escape-multibyte");
2253 staticpro (&Qprint_escape_multibyte
);
2255 Qprint_escape_nonascii
= intern_c_string ("print-escape-nonascii");
2256 staticpro (&Qprint_escape_nonascii
);
2258 print_prune_charset_plist
= Qnil
;
2259 staticpro (&print_prune_charset_plist
);