1 /* Lisp object printing and output streams.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2012
4 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
27 #include "character.h"
33 #include "dispextern.h"
35 #include "intervals.h"
36 #include "blockinput.h"
37 #include "termhooks.h" /* For struct terminal. */
42 Lisp_Object Qstandard_output
;
44 static Lisp_Object Qtemp_buffer_setup_hook
;
46 /* These are used to print like we read. */
48 static Lisp_Object Qfloat_output_format
;
54 /* Default to values appropriate for IEEE floating point. */
59 /* Avoid actual stack overflow in print. */
60 static int print_depth
;
62 /* Level of nesting inside outputting backquote in new style. */
63 static int new_backquote_output
;
65 /* Detect most circularities to print finite output. */
66 #define PRINT_CIRCLE 200
67 static Lisp_Object being_printed
[PRINT_CIRCLE
];
69 /* When printing into a buffer, first we put the text in this
70 block, then insert it all at once. */
71 static char *print_buffer
;
73 /* Size allocated in print_buffer. */
74 static EMACS_INT print_buffer_size
;
75 /* Chars stored in print_buffer. */
76 static EMACS_INT print_buffer_pos
;
77 /* Bytes stored in print_buffer. */
78 static EMACS_INT print_buffer_pos_byte
;
80 Lisp_Object Qprint_escape_newlines
;
81 static Lisp_Object Qprint_escape_multibyte
, Qprint_escape_nonascii
;
83 /* Vprint_number_table is a table, that keeps objects that are going to
84 be printed, to allow use of #n= and #n# to express sharing.
85 For any given object, the table can give the following values:
86 t the object will be printed only once.
87 -N the object will be printed several times and will take number N.
88 N the object has been printed so we can refer to it as #N#.
89 print_number_index holds the largest N already used.
90 N has to be striclty larger than 0 since we need to distinguish -N. */
91 static int print_number_index
;
92 static void print_interval (INTERVAL interval
, Lisp_Object printcharfun
);
94 /* GDB resets this to zero on W32 to disable OutputDebugString calls. */
95 int print_output_debug_flag EXTERNALLY_VISIBLE
= 1;
98 /* Low level output routines for characters and strings. */
100 /* Lisp functions to do output using a stream
101 must have the stream in a variable called printcharfun
102 and must start with PRINTPREPARE, end with PRINTFINISH,
103 and use PRINTDECLARE to declare common variables.
104 Use PRINTCHAR to output one character,
105 or call strout to output a block of characters. */
107 #define PRINTDECLARE \
108 struct buffer *old = current_buffer; \
109 EMACS_INT old_point = -1, start_point = -1; \
110 EMACS_INT old_point_byte = -1, start_point_byte = -1; \
111 int specpdl_count = SPECPDL_INDEX (); \
112 int free_print_buffer = 0; \
113 int multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters)); \
116 #define PRINTPREPARE \
117 original = printcharfun; \
118 if (NILP (printcharfun)) printcharfun = Qt; \
119 if (BUFFERP (printcharfun)) \
121 if (XBUFFER (printcharfun) != current_buffer) \
122 Fset_buffer (printcharfun); \
123 printcharfun = Qnil; \
125 if (MARKERP (printcharfun)) \
127 EMACS_INT marker_pos; \
128 if (! XMARKER (printcharfun)->buffer) \
129 error ("Marker does not point anywhere"); \
130 if (XMARKER (printcharfun)->buffer != current_buffer) \
131 set_buffer_internal (XMARKER (printcharfun)->buffer); \
132 marker_pos = marker_position (printcharfun); \
133 if (marker_pos < BEGV || marker_pos > ZV) \
134 error ("Marker is outside the accessible part of the buffer"); \
136 old_point_byte = PT_BYTE; \
137 SET_PT_BOTH (marker_pos, \
138 marker_byte_position (printcharfun)); \
140 start_point_byte = PT_BYTE; \
141 printcharfun = Qnil; \
143 if (NILP (printcharfun)) \
145 Lisp_Object string; \
146 if (NILP (BVAR (current_buffer, enable_multibyte_characters)) \
147 && ! print_escape_multibyte) \
148 specbind (Qprint_escape_multibyte, Qt); \
149 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)) \
150 && ! print_escape_nonascii) \
151 specbind (Qprint_escape_nonascii, Qt); \
152 if (print_buffer != 0) \
154 string = make_string_from_bytes (print_buffer, \
156 print_buffer_pos_byte); \
157 record_unwind_protect (print_unwind, string); \
161 ptrdiff_t new_size = 1000; \
162 print_buffer = (char *) xmalloc (new_size); \
163 print_buffer_size = new_size; \
164 free_print_buffer = 1; \
166 print_buffer_pos = 0; \
167 print_buffer_pos_byte = 0; \
169 if (EQ (printcharfun, Qt) && ! noninteractive) \
170 setup_echo_area_for_printing (multibyte);
172 #define PRINTFINISH \
173 if (NILP (printcharfun)) \
175 if (print_buffer_pos != print_buffer_pos_byte \
176 && NILP (BVAR (current_buffer, enable_multibyte_characters))) \
178 unsigned char *temp \
179 = (unsigned char *) alloca (print_buffer_pos + 1); \
180 copy_text ((unsigned char *) print_buffer, temp, \
181 print_buffer_pos_byte, 1, 0); \
182 insert_1_both ((char *) temp, print_buffer_pos, \
183 print_buffer_pos, 0, 1, 0); \
186 insert_1_both (print_buffer, print_buffer_pos, \
187 print_buffer_pos_byte, 0, 1, 0); \
188 signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
190 if (free_print_buffer) \
192 xfree (print_buffer); \
195 unbind_to (specpdl_count, Qnil); \
196 if (MARKERP (original)) \
197 set_marker_both (original, Qnil, PT, PT_BYTE); \
198 if (old_point >= 0) \
199 SET_PT_BOTH (old_point + (old_point >= start_point \
200 ? PT - start_point : 0), \
201 old_point_byte + (old_point_byte >= start_point_byte \
202 ? PT_BYTE - start_point_byte : 0)); \
203 if (old != current_buffer) \
204 set_buffer_internal (old);
206 #define PRINTCHAR(ch) printchar (ch, printcharfun)
208 /* This is used to restore the saved contents of print_buffer
209 when there is a recursive call to print. */
212 print_unwind (Lisp_Object saved_text
)
214 memcpy (print_buffer
, SDATA (saved_text
), SCHARS (saved_text
));
219 /* Print character CH using method FUN. FUN nil means print to
220 print_buffer. FUN t means print to echo area or stdout if
221 non-interactive. If FUN is neither nil nor t, call FUN with CH as
225 printchar (unsigned int ch
, Lisp_Object fun
)
227 if (!NILP (fun
) && !EQ (fun
, Qt
))
228 call1 (fun
, make_number (ch
));
231 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
232 int len
= CHAR_STRING (ch
, str
);
238 if (print_buffer_size
- len
<= print_buffer_pos_byte
)
241 if (STRING_BYTES_BOUND
/ 2 < print_buffer_size
)
243 new_size
= print_buffer_size
* 2;
244 print_buffer
= (char *) xrealloc (print_buffer
, new_size
);
245 print_buffer_size
= new_size
;
247 memcpy (print_buffer
+ print_buffer_pos_byte
, str
, len
);
248 print_buffer_pos
+= 1;
249 print_buffer_pos_byte
+= len
;
251 else if (noninteractive
)
253 fwrite (str
, 1, len
, stdout
);
254 noninteractive_need_newline
= 1;
259 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
261 setup_echo_area_for_printing (multibyte_p
);
263 message_dolog ((char *) str
, len
, 0, multibyte_p
);
269 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
270 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
271 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
272 print_buffer. PRINTCHARFUN t means output to the echo area or to
273 stdout if non-interactive. If neither nil nor t, call Lisp
274 function PRINTCHARFUN for each character printed. MULTIBYTE
275 non-zero means PTR contains multibyte characters.
277 In the case where PRINTCHARFUN is nil, it is safe for PTR to point
278 to data in a Lisp string. Otherwise that is not safe. */
281 strout (const char *ptr
, EMACS_INT size
, EMACS_INT size_byte
,
282 Lisp_Object printcharfun
)
285 size_byte
= size
= strlen (ptr
);
287 if (NILP (printcharfun
))
289 if (print_buffer_size
- size_byte
< print_buffer_pos_byte
)
292 if (STRING_BYTES_BOUND
/ 2 - size_byte
< print_buffer_size
)
294 new_size
= print_buffer_size
* 2 + size_byte
;
295 print_buffer
= (char *) xrealloc (print_buffer
, new_size
);
296 print_buffer_size
= new_size
;
298 memcpy (print_buffer
+ print_buffer_pos_byte
, ptr
, size_byte
);
299 print_buffer_pos
+= size
;
300 print_buffer_pos_byte
+= size_byte
;
302 else if (noninteractive
&& EQ (printcharfun
, Qt
))
304 fwrite (ptr
, 1, size_byte
, stdout
);
305 noninteractive_need_newline
= 1;
307 else if (EQ (printcharfun
, Qt
))
309 /* Output to echo area. We're trying to avoid a little overhead
310 here, that's the reason we don't call printchar to do the
314 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
316 setup_echo_area_for_printing (multibyte_p
);
317 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
319 if (size
== size_byte
)
321 for (i
= 0; i
< size
; ++i
)
322 insert_char ((unsigned char) *ptr
++);
327 for (i
= 0; i
< size_byte
; i
+= len
)
329 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
337 /* PRINTCHARFUN is a Lisp function. */
340 if (size
== size_byte
)
342 while (i
< size_byte
)
350 while (i
< size_byte
)
352 /* Here, we must convert each multi-byte form to the
353 corresponding character code before handing it to
356 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
365 /* Print the contents of a string STRING using PRINTCHARFUN.
366 It isn't safe to use strout in many cases,
367 because printing one char can relocate. */
370 print_string (Lisp_Object string
, Lisp_Object printcharfun
)
372 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
376 if (print_escape_nonascii
)
377 string
= string_escape_byte8 (string
);
379 if (STRING_MULTIBYTE (string
))
380 chars
= SCHARS (string
);
381 else if (! print_escape_nonascii
382 && (EQ (printcharfun
, Qt
)
383 ? ! NILP (BVAR (&buffer_defaults
, enable_multibyte_characters
))
384 : ! NILP (BVAR (current_buffer
, enable_multibyte_characters
))))
386 /* If unibyte string STRING contains 8-bit codes, we must
387 convert STRING to a multibyte string containing the same
392 chars
= SBYTES (string
);
393 bytes
= count_size_as_multibyte (SDATA (string
), chars
);
396 newstr
= make_uninit_multibyte_string (chars
, bytes
);
397 memcpy (SDATA (newstr
), SDATA (string
), chars
);
398 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
403 chars
= SBYTES (string
);
405 if (EQ (printcharfun
, Qt
))
407 /* Output to echo area. */
408 EMACS_INT nbytes
= SBYTES (string
);
411 /* Copy the string contents so that relocation of STRING by
412 GC does not cause trouble. */
415 SAFE_ALLOCA (buffer
, char *, nbytes
);
416 memcpy (buffer
, SDATA (string
), nbytes
);
418 strout (buffer
, chars
, SBYTES (string
), printcharfun
);
423 /* No need to copy, since output to print_buffer can't GC. */
424 strout (SSDATA (string
), chars
, SBYTES (string
), printcharfun
);
428 /* Otherwise, string may be relocated by printing one char.
429 So re-fetch the string address for each character. */
431 EMACS_INT size
= SCHARS (string
);
432 EMACS_INT size_byte
= SBYTES (string
);
435 if (size
== size_byte
)
436 for (i
= 0; i
< size
; i
++)
437 PRINTCHAR (SREF (string
, i
));
439 for (i
= 0; i
< size_byte
; )
441 /* Here, we must convert each multi-byte form to the
442 corresponding character code before handing it to PRINTCHAR. */
444 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
, len
);
452 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
453 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
454 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
455 (Lisp_Object character
, Lisp_Object printcharfun
)
459 if (NILP (printcharfun
))
460 printcharfun
= Vstandard_output
;
461 CHECK_NUMBER (character
);
463 PRINTCHAR (XINT (character
));
468 /* Used from outside of print.c to print a block of SIZE
469 single-byte chars at DATA on the default output stream.
470 Do not use this on the contents of a Lisp string. */
473 write_string (const char *data
, int size
)
476 Lisp_Object printcharfun
;
478 printcharfun
= Vstandard_output
;
481 strout (data
, size
, size
, printcharfun
);
485 /* Used to print a block of SIZE single-byte chars at DATA on a
486 specified stream PRINTCHARFUN.
487 Do not use this on the contents of a Lisp string. */
490 write_string_1 (const char *data
, int size
, Lisp_Object printcharfun
)
495 strout (data
, size
, size
, printcharfun
);
501 temp_output_buffer_setup (const char *bufname
)
503 int count
= SPECPDL_INDEX ();
504 register struct buffer
*old
= current_buffer
;
505 register Lisp_Object buf
;
507 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
509 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
511 Fkill_all_local_variables ();
512 delete_all_overlays (current_buffer
);
513 BVAR (current_buffer
, directory
) = BVAR (old
, directory
);
514 BVAR (current_buffer
, read_only
) = Qnil
;
515 BVAR (current_buffer
, filename
) = Qnil
;
516 BVAR (current_buffer
, undo_list
) = Qt
;
517 eassert (current_buffer
->overlays_before
== NULL
);
518 eassert (current_buffer
->overlays_after
== NULL
);
519 BVAR (current_buffer
, enable_multibyte_characters
)
520 = BVAR (&buffer_defaults
, enable_multibyte_characters
);
521 specbind (Qinhibit_read_only
, Qt
);
522 specbind (Qinhibit_modification_hooks
, Qt
);
524 XSETBUFFER (buf
, current_buffer
);
526 Frun_hooks (1, &Qtemp_buffer_setup_hook
);
528 unbind_to (count
, Qnil
);
530 specbind (Qstandard_output
, buf
);
533 static void print (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
);
534 static void print_preprocess (Lisp_Object obj
);
535 static void print_preprocess_string (INTERVAL interval
, Lisp_Object arg
);
536 static void print_object (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
);
538 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
539 doc
: /* Output a newline to stream PRINTCHARFUN.
540 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
541 (Lisp_Object printcharfun
)
545 if (NILP (printcharfun
))
546 printcharfun
= Vstandard_output
;
553 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
554 doc
: /* Output the printed representation of OBJECT, any Lisp object.
555 Quoting characters are printed when needed to make output that `read'
556 can handle, whenever this is possible. For complex objects, the behavior
557 is controlled by `print-level' and `print-length', which see.
559 OBJECT is any of the Lisp data types: a number, a string, a symbol,
560 a list, a buffer, a window, a frame, etc.
562 A printed representation of an object is text which describes that object.
564 Optional argument PRINTCHARFUN is the output stream, which can be one
567 - a buffer, in which case output is inserted into that buffer at point;
568 - a marker, in which case output is inserted at marker's position;
569 - a function, in which case that function is called once for each
570 character of OBJECT's printed representation;
571 - a symbol, in which case that symbol's function definition is called; or
572 - t, in which case the output is displayed in the echo area.
574 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
576 (Lisp_Object object
, Lisp_Object printcharfun
)
580 if (NILP (printcharfun
))
581 printcharfun
= Vstandard_output
;
583 print (object
, printcharfun
, 1);
588 /* a buffer which is used to hold output being built by prin1-to-string */
589 Lisp_Object Vprin1_to_string_buffer
;
591 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
592 doc
: /* Return a string containing the printed representation of OBJECT.
593 OBJECT can be any Lisp object. This function outputs quoting characters
594 when necessary to make output that `read' can handle, whenever possible,
595 unless the optional second argument NOESCAPE is non-nil. For complex objects,
596 the behavior is controlled by `print-level' and `print-length', which see.
598 OBJECT is any of the Lisp data types: a number, a string, a symbol,
599 a list, a buffer, a window, a frame, etc.
601 A printed representation of an object is text which describes that object. */)
602 (Lisp_Object object
, Lisp_Object noescape
)
604 Lisp_Object printcharfun
;
605 /* struct gcpro gcpro1, gcpro2; */
606 Lisp_Object save_deactivate_mark
;
607 int count
= SPECPDL_INDEX ();
608 struct buffer
*previous
;
610 specbind (Qinhibit_modification_hooks
, Qt
);
615 /* Save and restore this--we are altering a buffer
616 but we don't want to deactivate the mark just for that.
617 No need for specbind, since errors deactivate the mark. */
618 save_deactivate_mark
= Vdeactivate_mark
;
619 /* GCPRO2 (object, save_deactivate_mark); */
622 printcharfun
= Vprin1_to_string_buffer
;
624 print (object
, printcharfun
, NILP (noescape
));
625 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINISH */
629 previous
= current_buffer
;
630 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
631 object
= Fbuffer_string ();
632 if (SBYTES (object
) == SCHARS (object
))
633 STRING_SET_UNIBYTE (object
);
635 /* Note that this won't make prepare_to_modify_buffer call
636 ask-user-about-supersession-threat because this buffer
637 does not visit a file. */
639 set_buffer_internal (previous
);
641 Vdeactivate_mark
= save_deactivate_mark
;
645 return unbind_to (count
, object
);
648 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
649 doc
: /* Output the printed representation of OBJECT, any Lisp object.
650 No quoting characters are used; no delimiters are printed around
651 the contents of strings.
653 OBJECT is any of the Lisp data types: a number, a string, a symbol,
654 a list, a buffer, a window, a frame, etc.
656 A printed representation of an object is text which describes that object.
658 Optional argument PRINTCHARFUN is the output stream, which can be one
661 - a buffer, in which case output is inserted into that buffer at point;
662 - a marker, in which case output is inserted at marker's position;
663 - a function, in which case that function is called once for each
664 character of OBJECT's printed representation;
665 - a symbol, in which case that symbol's function definition is called; or
666 - t, in which case the output is displayed in the echo area.
668 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
670 (Lisp_Object object
, Lisp_Object printcharfun
)
674 if (NILP (printcharfun
))
675 printcharfun
= Vstandard_output
;
677 print (object
, printcharfun
, 0);
682 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
683 doc
: /* Output the printed representation of OBJECT, with newlines around it.
684 Quoting characters are printed when needed to make output that `read'
685 can handle, whenever this is possible. For complex objects, the behavior
686 is controlled by `print-level' and `print-length', which see.
688 OBJECT is any of the Lisp data types: a number, a string, a symbol,
689 a list, a buffer, a window, a frame, etc.
691 A printed representation of an object is text which describes that object.
693 Optional argument PRINTCHARFUN is the output stream, which can be one
696 - a buffer, in which case output is inserted into that buffer at point;
697 - a marker, in which case output is inserted at marker's position;
698 - a function, in which case that function is called once for each
699 character of OBJECT's printed representation;
700 - a symbol, in which case that symbol's function definition is called; or
701 - t, in which case the output is displayed in the echo area.
703 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
705 (Lisp_Object object
, Lisp_Object printcharfun
)
710 if (NILP (printcharfun
))
711 printcharfun
= Vstandard_output
;
715 print (object
, printcharfun
, 1);
722 /* The subroutine object for external-debugging-output is kept here
723 for the convenience of the debugger. */
724 Lisp_Object Qexternal_debugging_output
;
726 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
727 doc
: /* Write CHARACTER to stderr.
728 You can call print while debugging emacs, and pass it this function
729 to make it write to the debugging output. */)
730 (Lisp_Object character
)
732 CHECK_NUMBER (character
);
733 putc ((int) XINT (character
), stderr
);
736 /* Send the output to a debugger (nothing happens if there isn't one). */
737 if (print_output_debug_flag
)
739 char buf
[2] = {(char) XINT (character
), '\0'};
740 OutputDebugString (buf
);
747 /* This function is never called. Its purpose is to prevent
748 print_output_debug_flag from being optimized away. */
750 extern void debug_output_compilation_hack (int) EXTERNALLY_VISIBLE
;
752 debug_output_compilation_hack (int x
)
754 print_output_debug_flag
= x
;
757 #if defined (GNU_LINUX)
759 /* This functionality is not vitally important in general, so we rely on
760 non-portable ability to use stderr as lvalue. */
762 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
764 static FILE *initial_stderr_stream
= NULL
;
766 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
768 "FDebug output file: \nP",
769 doc
: /* Redirect debugging output (stderr stream) to file FILE.
770 If FILE is nil, reset target to the initial stderr stream.
771 Optional arg APPEND non-nil (interactively, with prefix arg) means
772 append to existing target file. */)
773 (Lisp_Object file
, Lisp_Object append
)
775 if (initial_stderr_stream
!= NULL
)
781 stderr
= initial_stderr_stream
;
782 initial_stderr_stream
= NULL
;
786 file
= Fexpand_file_name (file
, Qnil
);
787 initial_stderr_stream
= stderr
;
788 stderr
= fopen (SSDATA (file
), NILP (append
) ? "w" : "a");
791 stderr
= initial_stderr_stream
;
792 initial_stderr_stream
= NULL
;
793 report_file_error ("Cannot open debugging output stream",
799 #endif /* GNU_LINUX */
802 /* This is the interface for debugging printing. */
805 debug_print (Lisp_Object arg
)
807 Fprin1 (arg
, Qexternal_debugging_output
);
808 fprintf (stderr
, "\r\n");
811 void safe_debug_print (Lisp_Object
) EXTERNALLY_VISIBLE
;
813 safe_debug_print (Lisp_Object arg
)
815 int valid
= valid_lisp_object_p (arg
);
820 fprintf (stderr
, "#<%s_LISP_OBJECT 0x%08"pI
"x>\r\n",
821 !valid
? "INVALID" : "SOME",
826 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
828 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
829 See Info anchor `(elisp)Definition of signal' for some details on how this
830 error message is constructed. */)
833 struct buffer
*old
= current_buffer
;
837 /* If OBJ is (error STRING), just return STRING.
838 That is not only faster, it also avoids the need to allocate
839 space here when the error is due to memory full. */
840 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
841 && CONSP (XCDR (obj
))
842 && STRINGP (XCAR (XCDR (obj
)))
843 && NILP (XCDR (XCDR (obj
))))
844 return XCAR (XCDR (obj
));
846 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
848 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
849 value
= Fbuffer_string ();
853 set_buffer_internal (old
);
859 /* Print an error message for the error DATA onto Lisp output stream
860 STREAM (suitable for the print functions).
861 CONTEXT is a C string describing the context of the error.
862 CALLER is the Lisp function inside which the error was signaled. */
865 print_error_message (Lisp_Object data
, Lisp_Object stream
, const char *context
,
868 Lisp_Object errname
, errmsg
, file_error
, tail
;
872 write_string_1 (context
, -1, stream
);
874 /* If we know from where the error was signaled, show it in
876 if (!NILP (caller
) && SYMBOLP (caller
))
878 Lisp_Object cname
= SYMBOL_NAME (caller
);
879 char *name
= alloca (SBYTES (cname
));
880 memcpy (name
, SDATA (cname
), SBYTES (cname
));
881 message_dolog (name
, SBYTES (cname
), 0, 0);
882 message_dolog (": ", 2, 0, 0);
885 errname
= Fcar (data
);
887 if (EQ (errname
, Qerror
))
892 errmsg
= Fcar (data
);
897 Lisp_Object error_conditions
= Fget (errname
, Qerror_conditions
);
898 errmsg
= Fget (errname
, Qerror_message
);
899 file_error
= Fmemq (Qfile_error
, error_conditions
);
902 /* Print an error message including the data items. */
904 tail
= Fcdr_safe (data
);
907 /* For file-error, make error message by concatenating
908 all the data items. They are all strings. */
909 if (!NILP (file_error
) && CONSP (tail
))
910 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
913 const char *sep
= ": ";
915 if (!STRINGP (errmsg
))
916 write_string_1 ("peculiar error", -1, stream
);
917 else if (SCHARS (errmsg
))
918 Fprinc (errmsg
, stream
);
922 for (; CONSP (tail
); tail
= XCDR (tail
), sep
= ", ")
927 write_string_1 (sep
, 2, stream
);
929 if (!NILP (file_error
)
930 || EQ (errname
, Qend_of_file
) || EQ (errname
, Quser_error
))
931 Fprinc (obj
, stream
);
933 Fprin1 (obj
, stream
);
943 * The buffer should be at least as large as the max string size of the
944 * largest float, printed in the biggest notation. This is undoubtedly
945 * 20d float_output_format, with the negative of the C-constant "HUGE"
948 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
950 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
951 * case of -1e307 in 20d float_output_format. What is one to do (short of
952 * re-writing _doprnt to be more sane)?
954 * Given the above, the buffer must be least FLOAT_TO_STRING_BUFSIZE bytes.
958 float_to_string (char *buf
, double data
)
963 /* Check for plus infinity in a way that won't lose
964 if there is no plus infinity. */
965 if (data
== data
/ 2 && data
> 1.0)
967 strcpy (buf
, "1.0e+INF");
970 /* Likewise for minus infinity. */
971 if (data
== data
/ 2 && data
< -1.0)
973 strcpy (buf
, "-1.0e+INF");
976 /* Check for NaN in a way that won't fail if there are no NaNs. */
977 if (! (data
* 0.0 >= 0.0))
979 /* Prepend "-" if the NaN's sign bit is negative.
980 The sign bit of a double is the bit that is 1 in -0.0. */
982 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
984 u_minus_zero
.d
= - 0.0;
985 for (i
= 0; i
< sizeof (double); i
++)
986 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
992 strcpy (buf
, "0.0e+NaN");
996 if (NILP (Vfloat_output_format
)
997 || !STRINGP (Vfloat_output_format
))
1000 /* Generate the fewest number of digits that represent the
1001 floating point value without losing information. */
1002 dtoastr (buf
, FLOAT_TO_STRING_BUFSIZE
- 2, 0, 0, data
);
1003 /* The decimal point must be printed, or the byte compiler can
1004 get confused (Bug#8033). */
1007 else /* oink oink */
1009 /* Check that the spec we have is fully valid.
1010 This means not only valid for printf,
1011 but meant for floats, and reasonable. */
1012 cp
= SSDATA (Vfloat_output_format
);
1021 /* Check the width specification. */
1023 if ('0' <= *cp
&& *cp
<= '9')
1028 width
= (width
* 10) + (*cp
++ - '0');
1029 if (DBL_DIG
< width
)
1032 while (*cp
>= '0' && *cp
<= '9');
1034 /* A precision of zero is valid only for %f. */
1035 if (width
== 0 && *cp
!= 'f')
1039 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1045 sprintf (buf
, SSDATA (Vfloat_output_format
), data
);
1048 /* Make sure there is a decimal point with digit after, or an
1049 exponent, so that the value is readable as a float. But don't do
1050 this with "%.0f"; it's valid for that not to produce a decimal
1051 point. Note that width can be 0 only for %.0f. */
1054 for (cp
= buf
; *cp
; cp
++)
1055 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1058 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 Maybe a better way to do that is to copy elements to
1101 a new hash table. */
1102 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vprint_number_table
);
1105 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
1106 if (!NILP (HASH_HASH (h
, i
))
1107 && EQ (HASH_VALUE (h
, i
), Qt
))
1108 Fremhash (HASH_KEY (h
, i
), Vprint_number_table
);
1113 print_object (obj
, printcharfun
, escapeflag
);
1116 #define PRINT_CIRCLE_CANDIDATE_P(obj) \
1117 (STRINGP (obj) || CONSP (obj) \
1118 || (VECTORLIKEP (obj) \
1119 && (VECTORP (obj) || COMPILEDP (obj) \
1120 || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \
1121 || HASH_TABLE_P (obj) || FONTP (obj))) \
1122 || (! NILP (Vprint_gensym) \
1124 && !SYMBOL_INTERNED_P (obj)))
1126 /* Construct Vprint_number_table according to the structure of OBJ.
1127 OBJ itself and all its elements will be added to Vprint_number_table
1128 recursively if it is a list, vector, compiled function, char-table,
1129 string (its text properties will be traced), or a symbol that has
1130 no obarray (this is for the print-gensym feature).
1131 The status fields of Vprint_number_table mean whether each object appears
1132 more than once in OBJ: Qnil at the first time, and Qt after that . */
1134 print_preprocess (Lisp_Object obj
)
1139 Lisp_Object halftail
;
1141 /* Avoid infinite recursion for circular nested structure
1142 in the case where Vprint_circle is nil. */
1143 if (NILP (Vprint_circle
))
1145 /* Give up if we go so deep that print_object will get an error. */
1146 /* See similar code in print_object. */
1147 if (print_depth
>= PRINT_CIRCLE
)
1148 error ("Apparently circular structure being printed");
1150 for (i
= 0; i
< print_depth
; i
++)
1151 if (EQ (obj
, being_printed
[i
]))
1153 being_printed
[print_depth
] = obj
;
1160 if (PRINT_CIRCLE_CANDIDATE_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
:
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
)
1328 char buf
[max (sizeof "from..to..in " + 2 * INT_STRLEN_BOUND (EMACS_INT
),
1329 max (sizeof " . #" + INT_STRLEN_BOUND (printmax_t
),
1334 /* Detect circularities and truncate them. */
1335 if (NILP (Vprint_circle
))
1337 /* Simple but incomplete way. */
1340 /* See similar code in print_preprocess. */
1341 if (print_depth
>= PRINT_CIRCLE
)
1342 error ("Apparently circular structure being printed");
1344 for (i
= 0; i
< print_depth
; i
++)
1345 if (EQ (obj
, being_printed
[i
]))
1347 sprintf (buf
, "#%d", i
);
1348 strout (buf
, -1, -1, printcharfun
);
1351 being_printed
[print_depth
] = obj
;
1353 else if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1355 /* With the print-circle feature. */
1356 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1359 EMACS_INT n
= XINT (num
);
1361 { /* Add a prefix #n= if OBJ has not yet been printed;
1362 that is, its status field is nil. */
1363 sprintf (buf
, "#%"pI
"d=", -n
);
1364 strout (buf
, -1, -1, printcharfun
);
1365 /* OBJ is going to be printed. Remember that fact. */
1366 Fputhash (obj
, make_number (- n
), Vprint_number_table
);
1370 /* Just print #n# if OBJ has already been printed. */
1371 sprintf (buf
, "#%"pI
"d#", n
);
1372 strout (buf
, -1, -1, printcharfun
);
1380 switch (XTYPE (obj
))
1383 sprintf (buf
, "%"pI
"d", XINT (obj
));
1384 strout (buf
, -1, -1, printcharfun
);
1389 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
1391 float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1392 strout (pigbuf
, -1, -1, printcharfun
);
1398 print_string (obj
, printcharfun
);
1401 register EMACS_INT i_byte
;
1402 struct gcpro gcpro1
;
1404 EMACS_INT size_byte
;
1405 /* 1 means we must ensure that the next character we output
1406 cannot be taken as part of a hex character escape. */
1407 int need_nonhex
= 0;
1408 int multibyte
= STRING_MULTIBYTE (obj
);
1412 if (! EQ (Vprint_charset_text_property
, Qt
))
1413 obj
= print_prune_string_charset (obj
);
1415 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1423 size_byte
= SBYTES (obj
);
1425 for (i_byte
= 0; i_byte
< size_byte
;)
1427 /* Here, we must convert each multi-byte form to the
1428 corresponding character code before handing it to PRINTCHAR. */
1434 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
, len
);
1442 if (c
== '\n' && print_escape_newlines
)
1447 else if (c
== '\f' && print_escape_newlines
)
1453 && (CHAR_BYTE8_P (c
)
1454 || (! ASCII_CHAR_P (c
) && print_escape_multibyte
)))
1456 /* When multibyte is disabled,
1457 print multibyte string chars using hex escapes.
1458 For a char code that could be in a unibyte string,
1459 when found in a multibyte string, always use a hex escape
1460 so it reads back as multibyte. */
1463 if (CHAR_BYTE8_P (c
))
1464 sprintf (outbuf
, "\\%03o", CHAR_TO_BYTE8 (c
));
1467 sprintf (outbuf
, "\\x%04x", c
);
1470 strout (outbuf
, -1, -1, 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 sprintf (outbuf
, "\\%03o", c
);
1482 strout (outbuf
, -1, -1, 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
));
1523 EMACS_INT 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 sprintf (buf
, " . #%"pMd
, i
/ 2);
1648 strout (buf
, -1, -1, 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
))
1712 register unsigned char c
;
1713 struct gcpro gcpro1
;
1714 EMACS_INT size_in_chars
1715 = ((XBOOL_VECTOR (obj
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
1716 / BOOL_VECTOR_BITS_PER_CHAR
);
1722 sprintf (buf
, "%"pI
"d", XBOOL_VECTOR (obj
)->size
);
1723 strout (buf
, -1, -1, printcharfun
);
1726 /* Don't print more characters than the specified maximum.
1727 Negative values of print-length are invalid. Treat them
1728 like a print-length of nil. */
1729 if (NATNUMP (Vprint_length
)
1730 && XFASTINT (Vprint_length
) < size_in_chars
)
1731 size_in_chars
= XFASTINT (Vprint_length
);
1733 for (i
= 0; i
< size_in_chars
; i
++)
1736 c
= XBOOL_VECTOR (obj
)->data
[i
];
1737 if (c
== '\n' && print_escape_newlines
)
1742 else if (c
== '\f' && print_escape_newlines
)
1747 else if (c
> '\177')
1749 /* Use octal escapes to avoid encoding issues. */
1751 PRINTCHAR ('0' + ((c
>> 6) & 3));
1752 PRINTCHAR ('0' + ((c
>> 3) & 7));
1753 PRINTCHAR ('0' + (c
& 7));
1757 if (c
== '\"' || c
== '\\')
1766 else if (SUBRP (obj
))
1768 strout ("#<subr ", -1, -1, printcharfun
);
1769 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
);
1772 #ifdef HAVE_XWIDGETS
1773 else if (XXWIDGETP (obj
))
1775 strout ("#<xwidget ", -1, -1, printcharfun
);
1779 else if (WINDOWP (obj
))
1781 strout ("#<window ", -1, -1, printcharfun
);
1782 sprintf (buf
, "%"pI
"d", XFASTINT (XWINDOW (obj
)->sequence_number
));
1783 strout (buf
, -1, -1, printcharfun
);
1784 if (!NILP (XWINDOW (obj
)->buffer
))
1786 strout (" on ", -1, -1, printcharfun
);
1787 print_string (BVAR (XBUFFER (XWINDOW (obj
)->buffer
), name
), printcharfun
);
1791 else if (TERMINALP (obj
))
1793 struct terminal
*t
= XTERMINAL (obj
);
1794 strout ("#<terminal ", -1, -1, printcharfun
);
1795 sprintf (buf
, "%d", t
->id
);
1796 strout (buf
, -1, -1, printcharfun
);
1799 strout (" on ", -1, -1, printcharfun
);
1800 strout (t
->name
, -1, -1, printcharfun
);
1804 else if (HASH_TABLE_P (obj
))
1806 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1808 EMACS_INT real_size
, size
;
1810 strout ("#<hash-table", -1, -1, printcharfun
);
1811 if (SYMBOLP (h
->test
))
1815 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
);
1817 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
);
1819 sprintf (buf
, "%"pI
"d/%"pI
"d", h
->count
, ASIZE (h
->next
));
1820 strout (buf
, -1, -1, printcharfun
);
1822 sprintf (buf
, " %p", h
);
1823 strout (buf
, -1, -1, printcharfun
);
1826 /* Implement a readable output, e.g.:
1827 #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
1828 /* Always print the size. */
1829 sprintf (buf
, "#s(hash-table size %"pI
"d", ASIZE (h
->next
));
1830 strout (buf
, -1, -1, printcharfun
);
1832 if (!NILP (h
->test
))
1834 strout (" test ", -1, -1, printcharfun
);
1835 print_object (h
->test
, printcharfun
, escapeflag
);
1838 if (!NILP (h
->weak
))
1840 strout (" weakness ", -1, -1, printcharfun
);
1841 print_object (h
->weak
, printcharfun
, escapeflag
);
1844 if (!NILP (h
->rehash_size
))
1846 strout (" rehash-size ", -1, -1, printcharfun
);
1847 print_object (h
->rehash_size
, printcharfun
, escapeflag
);
1850 if (!NILP (h
->rehash_threshold
))
1852 strout (" rehash-threshold ", -1, -1, printcharfun
);
1853 print_object (h
->rehash_threshold
, printcharfun
, escapeflag
);
1856 strout (" data ", -1, -1, printcharfun
);
1858 /* Print the data here as a plist. */
1859 real_size
= HASH_TABLE_SIZE (h
);
1862 /* Don't print more elements than the specified maximum. */
1863 if (NATNUMP (Vprint_length
)
1864 && XFASTINT (Vprint_length
) < size
)
1865 size
= XFASTINT (Vprint_length
);
1868 for (i
= 0; i
< size
; i
++)
1869 if (!NILP (HASH_HASH (h
, i
)))
1871 if (i
) PRINTCHAR (' ');
1872 print_object (HASH_KEY (h
, i
), printcharfun
, escapeflag
);
1874 print_object (HASH_VALUE (h
, i
), printcharfun
, escapeflag
);
1877 if (size
< real_size
)
1878 strout (" ...", 4, 4, printcharfun
);
1884 else if (BUFFERP (obj
))
1886 if (NILP (BVAR (XBUFFER (obj
), name
)))
1887 strout ("#<killed buffer>", -1, -1, printcharfun
);
1888 else if (escapeflag
)
1890 strout ("#<buffer ", -1, -1, printcharfun
);
1891 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1895 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1897 else if (WINDOW_CONFIGURATIONP (obj
))
1899 strout ("#<window-configuration>", -1, -1, printcharfun
);
1901 else if (FRAMEP (obj
))
1903 strout ((FRAME_LIVE_P (XFRAME (obj
))
1904 ? "#<frame " : "#<dead frame "),
1905 -1, -1, printcharfun
);
1906 print_string (XFRAME (obj
)->name
, printcharfun
);
1907 sprintf (buf
, " %p", XFRAME (obj
));
1908 strout (buf
, -1, -1, printcharfun
);
1911 else if (FONTP (obj
))
1915 if (! FONT_OBJECT_P (obj
))
1917 if (FONT_SPEC_P (obj
))
1918 strout ("#<font-spec", -1, -1, printcharfun
);
1920 strout ("#<font-entity", -1, -1, printcharfun
);
1921 for (i
= 0; i
< FONT_SPEC_MAX
; i
++)
1924 if (i
< FONT_WEIGHT_INDEX
|| i
> FONT_WIDTH_INDEX
)
1925 print_object (AREF (obj
, i
), printcharfun
, escapeflag
);
1927 print_object (font_style_symbolic (obj
, i
, 0),
1928 printcharfun
, escapeflag
);
1933 strout ("#<font-object ", -1, -1, printcharfun
);
1934 print_object (AREF (obj
, FONT_NAME_INDEX
), printcharfun
,
1941 EMACS_INT size
= ASIZE (obj
);
1942 if (COMPILEDP (obj
))
1945 size
&= PSEUDOVECTOR_SIZE_MASK
;
1947 if (CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
))
1949 /* We print a char-table as if it were a vector,
1950 lumping the parent and default slots in with the
1951 character slots. But we add #^ as a prefix. */
1953 /* Make each lowest sub_char_table start a new line.
1954 Otherwise we'll make a line extremely long, which
1955 results in slow redisplay. */
1956 if (SUB_CHAR_TABLE_P (obj
)
1957 && XINT (XSUB_CHAR_TABLE (obj
)->depth
) == 3)
1961 if (SUB_CHAR_TABLE_P (obj
))
1963 size
&= PSEUDOVECTOR_SIZE_MASK
;
1965 if (size
& PSEUDOVECTOR_FLAG
)
1971 register Lisp_Object tem
;
1972 EMACS_INT real_size
= size
;
1974 /* Don't print more elements than the specified maximum. */
1975 if (NATNUMP (Vprint_length
)
1976 && XFASTINT (Vprint_length
) < size
)
1977 size
= XFASTINT (Vprint_length
);
1979 for (i
= 0; i
< size
; i
++)
1981 if (i
) PRINTCHAR (' ');
1982 tem
= XVECTOR (obj
)->contents
[i
];
1983 print_object (tem
, printcharfun
, escapeflag
);
1985 if (size
< real_size
)
1986 strout (" ...", 4, 4, printcharfun
);
1993 switch (XMISCTYPE (obj
))
1995 case Lisp_Misc_Marker
:
1996 strout ("#<marker ", -1, -1, printcharfun
);
1997 /* Do you think this is necessary? */
1998 if (XMARKER (obj
)->insertion_type
!= 0)
1999 strout ("(moves after insertion) ", -1, -1, printcharfun
);
2000 if (! XMARKER (obj
)->buffer
)
2001 strout ("in no buffer", -1, -1, printcharfun
);
2004 sprintf (buf
, "at %"pI
"d", marker_position (obj
));
2005 strout (buf
, -1, -1, printcharfun
);
2006 strout (" in ", -1, -1, printcharfun
);
2007 print_string (BVAR (XMARKER (obj
)->buffer
, name
), printcharfun
);
2012 case Lisp_Misc_Overlay
:
2013 strout ("#<overlay ", -1, -1, printcharfun
);
2014 if (! XMARKER (OVERLAY_START (obj
))->buffer
)
2015 strout ("in no buffer", -1, -1, printcharfun
);
2018 sprintf (buf
, "from %"pI
"d to %"pI
"d in ",
2019 marker_position (OVERLAY_START (obj
)),
2020 marker_position (OVERLAY_END (obj
)));
2021 strout (buf
, -1, -1, printcharfun
);
2022 print_string (BVAR (XMARKER (OVERLAY_START (obj
))->buffer
, name
),
2028 /* Remaining cases shouldn't happen in normal usage, but let's print
2029 them anyway for the benefit of the debugger. */
2030 case Lisp_Misc_Free
:
2031 strout ("#<misc free cell>", -1, -1, printcharfun
);
2034 case Lisp_Misc_Save_Value
:
2035 strout ("#<save_value ", -1, -1, printcharfun
);
2036 sprintf (buf
, "ptr=%p int=%"pD
"d",
2037 XSAVE_VALUE (obj
)->pointer
,
2038 XSAVE_VALUE (obj
)->integer
);
2039 strout (buf
, -1, -1, printcharfun
);
2051 /* We're in trouble if this happens!
2052 Probably should just abort () */
2053 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
);
2055 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2056 else if (VECTORLIKEP (obj
))
2057 sprintf (buf
, "(PVEC 0x%08"pI
"x)", ASIZE (obj
));
2059 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2060 strout (buf
, -1, -1, printcharfun
);
2061 strout (" Save your buffers immediately and please report this bug>",
2062 -1, -1, printcharfun
);
2070 /* Print a description of INTERVAL using PRINTCHARFUN.
2071 This is part of printing a string that has text properties. */
2074 print_interval (INTERVAL interval
, Lisp_Object printcharfun
)
2076 if (NILP (interval
->plist
))
2079 print_object (make_number (interval
->position
), printcharfun
, 1);
2081 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2084 print_object (interval
->plist
, printcharfun
, 1);
2089 syms_of_print (void)
2091 DEFSYM (Qtemp_buffer_setup_hook
, "temp-buffer-setup-hook");
2093 DEFVAR_LISP ("standard-output", Vstandard_output
,
2094 doc
: /* Output stream `print' uses by default for outputting a character.
2095 This may be any function of one argument.
2096 It may also be a buffer (output is inserted before point)
2097 or a marker (output is inserted and the marker is advanced)
2098 or the symbol t (output appears in the echo area). */);
2099 Vstandard_output
= Qt
;
2100 DEFSYM (Qstandard_output
, "standard-output");
2102 DEFVAR_LISP ("float-output-format", Vfloat_output_format
,
2103 doc
: /* The format descriptor string used to print floats.
2104 This is a %-spec like those accepted by `printf' in C,
2105 but with some restrictions. It must start with the two characters `%.'.
2106 After that comes an integer precision specification,
2107 and then a letter which controls the format.
2108 The letters allowed are `e', `f' and `g'.
2109 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2110 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2111 Use `g' to choose the shorter of those two formats for the number at hand.
2112 The precision in any of these cases is the number of digits following
2113 the decimal point. With `f', a precision of 0 means to omit the
2114 decimal point. 0 is not allowed with `e' or `g'.
2116 A value of nil means to use the shortest notation
2117 that represents the number without losing information. */);
2118 Vfloat_output_format
= Qnil
;
2119 DEFSYM (Qfloat_output_format
, "float-output-format");
2121 DEFVAR_LISP ("print-length", Vprint_length
,
2122 doc
: /* Maximum length of list to print before abbreviating.
2123 A value of nil means no limit. See also `eval-expression-print-length'. */);
2124 Vprint_length
= Qnil
;
2126 DEFVAR_LISP ("print-level", Vprint_level
,
2127 doc
: /* Maximum depth of list nesting to print before abbreviating.
2128 A value of nil means no limit. See also `eval-expression-print-level'. */);
2129 Vprint_level
= Qnil
;
2131 DEFVAR_BOOL ("print-escape-newlines", print_escape_newlines
,
2132 doc
: /* Non-nil means print newlines in strings as `\\n'.
2133 Also print formfeeds as `\\f'. */);
2134 print_escape_newlines
= 0;
2136 DEFVAR_BOOL ("print-escape-nonascii", print_escape_nonascii
,
2137 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2138 \(OOO is the octal representation of the character code.)
2139 Only single-byte characters are affected, and only in `prin1'.
2140 When the output goes in a multibyte buffer, this feature is
2141 enabled regardless of the value of the variable. */);
2142 print_escape_nonascii
= 0;
2144 DEFVAR_BOOL ("print-escape-multibyte", print_escape_multibyte
,
2145 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2146 \(XXXX is the hex representation of the character code.)
2147 This affects only `prin1'. */);
2148 print_escape_multibyte
= 0;
2150 DEFVAR_BOOL ("print-quoted", print_quoted
,
2151 doc
: /* Non-nil means print quoted forms with reader syntax.
2152 I.e., (quote foo) prints as 'foo, (function foo) as #'foo. */);
2155 DEFVAR_LISP ("print-gensym", Vprint_gensym
,
2156 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2157 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2158 When the uninterned symbol appears within a recursive data structure,
2159 and the symbol appears more than once, in addition use the #N# and #N=
2160 constructs as needed, so that multiple references to the same symbol are
2161 shared once again when the text is read back. */);
2162 Vprint_gensym
= Qnil
;
2164 DEFVAR_LISP ("print-circle", Vprint_circle
,
2165 doc
: /* Non-nil means print recursive structures using #N= and #N# syntax.
2166 If nil, printing proceeds recursively and may lead to
2167 `max-lisp-eval-depth' being exceeded or an error may occur:
2168 \"Apparently circular structure being printed.\" Also see
2169 `print-length' and `print-level'.
2170 If non-nil, shared substructures anywhere in the structure are printed
2171 with `#N=' before the first occurrence (in the order of the print
2172 representation) and `#N#' in place of each subsequent occurrence,
2173 where N is a positive decimal integer. */);
2174 Vprint_circle
= Qnil
;
2176 DEFVAR_LISP ("print-continuous-numbering", Vprint_continuous_numbering
,
2177 doc
: /* Non-nil means number continuously across print calls.
2178 This affects the numbers printed for #N= labels and #M# references.
2179 See also `print-circle', `print-gensym', and `print-number-table'.
2180 This variable should not be set with `setq'; bind it with a `let' instead. */);
2181 Vprint_continuous_numbering
= Qnil
;
2183 DEFVAR_LISP ("print-number-table", Vprint_number_table
,
2184 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2185 The Lisp printer uses this vector to detect Lisp objects referenced more
2188 When you bind `print-continuous-numbering' to t, you should probably
2189 also bind `print-number-table' to nil. This ensures that the value of
2190 `print-number-table' can be garbage-collected once the printing is
2191 done. If all elements of `print-number-table' are nil, it means that
2192 the printing done so far has not found any shared structure or objects
2193 that need to be recorded in the table. */);
2194 Vprint_number_table
= Qnil
;
2196 DEFVAR_LISP ("print-charset-text-property", Vprint_charset_text_property
,
2197 doc
: /* A flag to control printing of `charset' text property on printing a string.
2198 The value must be nil, t, or `default'.
2200 If the value is nil, don't print the text property `charset'.
2202 If the value is t, always print the text property `charset'.
2204 If the value is `default', print the text property `charset' only when
2205 the value is different from what is guessed in the current charset
2207 Vprint_charset_text_property
= Qdefault
;
2209 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2210 staticpro (&Vprin1_to_string_buffer
);
2213 defsubr (&Sprin1_to_string
);
2214 defsubr (&Serror_message_string
);
2218 defsubr (&Swrite_char
);
2219 defsubr (&Sexternal_debugging_output
);
2220 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2221 defsubr (&Sredirect_debugging_output
);
2224 DEFSYM (Qexternal_debugging_output
, "external-debugging-output");
2225 DEFSYM (Qprint_escape_newlines
, "print-escape-newlines");
2226 DEFSYM (Qprint_escape_multibyte
, "print-escape-multibyte");
2227 DEFSYM (Qprint_escape_nonascii
, "print-escape-nonascii");
2229 print_prune_charset_plist
= Qnil
;
2230 staticpro (&print_prune_charset_plist
);