1 /* Lisp object printing and output streams.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2011
4 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
27 #include "character.h"
33 #include "dispextern.h"
35 #include "intervals.h"
36 #include "blockinput.h"
37 #include "termhooks.h" /* For struct terminal. */
40 Lisp_Object Qstandard_output
;
42 static Lisp_Object Qtemp_buffer_setup_hook
;
44 /* These are used to print like we read. */
46 static Lisp_Object Qfloat_output_format
;
55 /* Default to values appropriate for IEEE floating point. */
60 /* Avoid actual stack overflow in print. */
61 static int print_depth
;
63 /* Level of nesting inside outputting backquote in new style. */
64 static int new_backquote_output
;
66 /* Detect most circularities to print finite output. */
67 #define PRINT_CIRCLE 200
68 static Lisp_Object being_printed
[PRINT_CIRCLE
];
70 /* When printing into a buffer, first we put the text in this
71 block, then insert it all at once. */
72 static char *print_buffer
;
74 /* Size allocated in print_buffer. */
75 static EMACS_INT print_buffer_size
;
76 /* Chars stored in print_buffer. */
77 static EMACS_INT print_buffer_pos
;
78 /* Bytes stored in print_buffer. */
79 static EMACS_INT print_buffer_pos_byte
;
81 Lisp_Object Qprint_escape_newlines
;
82 static Lisp_Object Qprint_escape_multibyte
, Qprint_escape_nonascii
;
84 /* Vprint_number_table is a table, that keeps objects that are going to
85 be printed, to allow use of #n= and #n# to express sharing.
86 For any given object, the table can give the following values:
87 t the object will be printed only once.
88 -N the object will be printed several times and will take number N.
89 N the object has been printed so we can refer to it as #N#.
90 print_number_index holds the largest N already used.
91 N has to be striclty larger than 0 since we need to distinguish -N. */
92 static int print_number_index
;
93 static void print_interval (INTERVAL interval
, Lisp_Object printcharfun
);
95 /* GDB resets this to zero on W32 to disable OutputDebugString calls. */
96 int print_output_debug_flag EXTERNALLY_VISIBLE
= 1;
99 /* Low level output routines for characters and strings */
101 /* Lisp functions to do output using a stream
102 must have the stream in a variable called printcharfun
103 and must start with PRINTPREPARE, end with PRINTFINISH,
104 and use PRINTDECLARE to declare common variables.
105 Use PRINTCHAR to output one character,
106 or call strout to output a block of characters. */
108 #define PRINTDECLARE \
109 struct buffer *old = current_buffer; \
110 EMACS_INT old_point = -1, start_point = -1; \
111 EMACS_INT old_point_byte = -1, start_point_byte = -1; \
112 int specpdl_count = SPECPDL_INDEX (); \
113 int free_print_buffer = 0; \
114 int multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters)); \
117 #define PRINTPREPARE \
118 original = printcharfun; \
119 if (NILP (printcharfun)) printcharfun = Qt; \
120 if (BUFFERP (printcharfun)) \
122 if (XBUFFER (printcharfun) != current_buffer) \
123 Fset_buffer (printcharfun); \
124 printcharfun = Qnil; \
126 if (MARKERP (printcharfun)) \
128 EMACS_INT marker_pos; \
129 if (! XMARKER (printcharfun)->buffer) \
130 error ("Marker does not point anywhere"); \
131 if (XMARKER (printcharfun)->buffer != current_buffer) \
132 set_buffer_internal (XMARKER (printcharfun)->buffer); \
133 marker_pos = marker_position (printcharfun); \
134 if (marker_pos < BEGV || marker_pos > ZV) \
135 error ("Marker is outside the accessible part of the buffer"); \
137 old_point_byte = PT_BYTE; \
138 SET_PT_BOTH (marker_pos, \
139 marker_byte_position (printcharfun)); \
141 start_point_byte = PT_BYTE; \
142 printcharfun = Qnil; \
144 if (NILP (printcharfun)) \
146 Lisp_Object string; \
147 if (NILP (BVAR (current_buffer, enable_multibyte_characters)) \
148 && ! print_escape_multibyte) \
149 specbind (Qprint_escape_multibyte, Qt); \
150 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)) \
151 && ! print_escape_nonascii) \
152 specbind (Qprint_escape_nonascii, Qt); \
153 if (print_buffer != 0) \
155 string = make_string_from_bytes (print_buffer, \
157 print_buffer_pos_byte); \
158 record_unwind_protect (print_unwind, string); \
162 ptrdiff_t new_size = 1000; \
163 print_buffer = (char *) xmalloc (new_size); \
164 print_buffer_size = new_size; \
165 free_print_buffer = 1; \
167 print_buffer_pos = 0; \
168 print_buffer_pos_byte = 0; \
170 if (EQ (printcharfun, Qt) && ! noninteractive) \
171 setup_echo_area_for_printing (multibyte);
173 #define PRINTFINISH \
174 if (NILP (printcharfun)) \
176 if (print_buffer_pos != print_buffer_pos_byte \
177 && NILP (BVAR (current_buffer, enable_multibyte_characters))) \
179 unsigned char *temp \
180 = (unsigned char *) alloca (print_buffer_pos + 1); \
181 copy_text ((unsigned char *) print_buffer, temp, \
182 print_buffer_pos_byte, 1, 0); \
183 insert_1_both ((char *) temp, print_buffer_pos, \
184 print_buffer_pos, 0, 1, 0); \
187 insert_1_both (print_buffer, print_buffer_pos, \
188 print_buffer_pos_byte, 0, 1, 0); \
189 signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
191 if (free_print_buffer) \
193 xfree (print_buffer); \
196 unbind_to (specpdl_count, Qnil); \
197 if (MARKERP (original)) \
198 set_marker_both (original, Qnil, PT, PT_BYTE); \
199 if (old_point >= 0) \
200 SET_PT_BOTH (old_point + (old_point >= start_point \
201 ? PT - start_point : 0), \
202 old_point_byte + (old_point_byte >= start_point_byte \
203 ? PT_BYTE - start_point_byte : 0)); \
204 if (old != current_buffer) \
205 set_buffer_internal (old);
207 #define PRINTCHAR(ch) printchar (ch, printcharfun)
209 /* This is used to restore the saved contents of print_buffer
210 when there is a recursive call to print. */
213 print_unwind (Lisp_Object saved_text
)
215 memcpy (print_buffer
, SDATA (saved_text
), SCHARS (saved_text
));
220 /* Print character CH using method FUN. FUN nil means print to
221 print_buffer. FUN t means print to echo area or stdout if
222 non-interactive. If FUN is neither nil nor t, call FUN with CH as
226 printchar (unsigned int ch
, Lisp_Object fun
)
228 if (!NILP (fun
) && !EQ (fun
, Qt
))
229 call1 (fun
, make_number (ch
));
232 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
233 int len
= CHAR_STRING (ch
, str
);
239 if (print_buffer_size
- len
<= print_buffer_pos_byte
)
242 if (STRING_BYTES_BOUND
/ 2 < print_buffer_size
)
244 new_size
= print_buffer_size
* 2;
245 print_buffer
= (char *) xrealloc (print_buffer
, new_size
);
246 print_buffer_size
= new_size
;
248 memcpy (print_buffer
+ print_buffer_pos_byte
, str
, len
);
249 print_buffer_pos
+= 1;
250 print_buffer_pos_byte
+= len
;
252 else if (noninteractive
)
254 fwrite (str
, 1, len
, stdout
);
255 noninteractive_need_newline
= 1;
260 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
262 setup_echo_area_for_printing (multibyte_p
);
264 message_dolog ((char *) str
, len
, 0, multibyte_p
);
270 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
271 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
272 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
273 print_buffer. PRINTCHARFUN t means output to the echo area or to
274 stdout if non-interactive. If neither nil nor t, call Lisp
275 function PRINTCHARFUN for each character printed. MULTIBYTE
276 non-zero means PTR contains multibyte characters.
278 In the case where PRINTCHARFUN is nil, it is safe for PTR to point
279 to data in a Lisp string. Otherwise that is not safe. */
282 strout (const char *ptr
, EMACS_INT size
, EMACS_INT size_byte
,
283 Lisp_Object printcharfun
)
286 size_byte
= size
= strlen (ptr
);
288 if (NILP (printcharfun
))
290 if (print_buffer_size
- size_byte
< print_buffer_pos_byte
)
293 if (STRING_BYTES_BOUND
/ 2 - size_byte
< print_buffer_size
)
295 new_size
= print_buffer_size
* 2 + size_byte
;
296 print_buffer
= (char *) xrealloc (print_buffer
, new_size
);
297 print_buffer_size
= new_size
;
299 memcpy (print_buffer
+ print_buffer_pos_byte
, ptr
, size_byte
);
300 print_buffer_pos
+= size
;
301 print_buffer_pos_byte
+= size_byte
;
303 else if (noninteractive
&& EQ (printcharfun
, Qt
))
305 fwrite (ptr
, 1, size_byte
, stdout
);
306 noninteractive_need_newline
= 1;
308 else if (EQ (printcharfun
, Qt
))
310 /* Output to echo area. We're trying to avoid a little overhead
311 here, that's the reason we don't call printchar to do the
315 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
317 setup_echo_area_for_printing (multibyte_p
);
318 message_dolog (ptr
, size_byte
, 0, multibyte_p
);
320 if (size
== size_byte
)
322 for (i
= 0; i
< size
; ++i
)
323 insert_char ((unsigned char) *ptr
++);
328 for (i
= 0; i
< size_byte
; i
+= len
)
330 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
338 /* PRINTCHARFUN is a Lisp function. */
341 if (size
== size_byte
)
343 while (i
< size_byte
)
351 while (i
< size_byte
)
353 /* Here, we must convert each multi-byte form to the
354 corresponding character code before handing it to
357 int ch
= STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr
+ i
,
366 /* Print the contents of a string STRING using PRINTCHARFUN.
367 It isn't safe to use strout in many cases,
368 because printing one char can relocate. */
371 print_string (Lisp_Object string
, Lisp_Object printcharfun
)
373 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
377 if (print_escape_nonascii
)
378 string
= string_escape_byte8 (string
);
380 if (STRING_MULTIBYTE (string
))
381 chars
= SCHARS (string
);
382 else if (! print_escape_nonascii
383 && (EQ (printcharfun
, Qt
)
384 ? ! NILP (BVAR (&buffer_defaults
, enable_multibyte_characters
))
385 : ! NILP (BVAR (current_buffer
, enable_multibyte_characters
))))
387 /* If unibyte string STRING contains 8-bit codes, we must
388 convert STRING to a multibyte string containing the same
393 chars
= SBYTES (string
);
394 bytes
= count_size_as_multibyte (SDATA (string
), chars
);
397 newstr
= make_uninit_multibyte_string (chars
, bytes
);
398 memcpy (SDATA (newstr
), SDATA (string
), chars
);
399 str_to_multibyte (SDATA (newstr
), bytes
, chars
);
404 chars
= SBYTES (string
);
406 if (EQ (printcharfun
, Qt
))
408 /* Output to echo area. */
409 EMACS_INT nbytes
= SBYTES (string
);
412 /* Copy the string contents so that relocation of STRING by
413 GC does not cause trouble. */
416 SAFE_ALLOCA (buffer
, char *, nbytes
);
417 memcpy (buffer
, SDATA (string
), nbytes
);
419 strout (buffer
, chars
, SBYTES (string
), printcharfun
);
424 /* No need to copy, since output to print_buffer can't GC. */
425 strout (SSDATA (string
), chars
, SBYTES (string
), printcharfun
);
429 /* Otherwise, string may be relocated by printing one char.
430 So re-fetch the string address for each character. */
432 EMACS_INT size
= SCHARS (string
);
433 EMACS_INT size_byte
= SBYTES (string
);
436 if (size
== size_byte
)
437 for (i
= 0; i
< size
; i
++)
438 PRINTCHAR (SREF (string
, i
));
440 for (i
= 0; i
< size_byte
; )
442 /* Here, we must convert each multi-byte form to the
443 corresponding character code before handing it to PRINTCHAR. */
445 int ch
= STRING_CHAR_AND_LENGTH (SDATA (string
) + i
, len
);
453 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
454 doc
: /* Output character CHARACTER to stream PRINTCHARFUN.
455 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
456 (Lisp_Object character
, Lisp_Object printcharfun
)
460 if (NILP (printcharfun
))
461 printcharfun
= Vstandard_output
;
462 CHECK_NUMBER (character
);
464 PRINTCHAR (XINT (character
));
469 /* Used from outside of print.c to print a block of SIZE
470 single-byte chars at DATA on the default output stream.
471 Do not use this on the contents of a Lisp string. */
474 write_string (const char *data
, int size
)
477 Lisp_Object printcharfun
;
479 printcharfun
= Vstandard_output
;
482 strout (data
, size
, size
, printcharfun
);
486 /* Used to print a block of SIZE single-byte chars at DATA on a
487 specified stream PRINTCHARFUN.
488 Do not use this on the contents of a Lisp string. */
491 write_string_1 (const char *data
, int size
, Lisp_Object printcharfun
)
496 strout (data
, size
, size
, printcharfun
);
502 temp_output_buffer_setup (const char *bufname
)
504 int count
= SPECPDL_INDEX ();
505 register struct buffer
*old
= current_buffer
;
506 register Lisp_Object buf
;
508 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
510 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
512 Fkill_all_local_variables ();
513 delete_all_overlays (current_buffer
);
514 BVAR (current_buffer
, directory
) = BVAR (old
, directory
);
515 BVAR (current_buffer
, read_only
) = Qnil
;
516 BVAR (current_buffer
, filename
) = Qnil
;
517 BVAR (current_buffer
, undo_list
) = Qt
;
518 eassert (current_buffer
->overlays_before
== NULL
);
519 eassert (current_buffer
->overlays_after
== NULL
);
520 BVAR (current_buffer
, enable_multibyte_characters
)
521 = BVAR (&buffer_defaults
, enable_multibyte_characters
);
522 specbind (Qinhibit_read_only
, Qt
);
523 specbind (Qinhibit_modification_hooks
, Qt
);
525 XSETBUFFER (buf
, current_buffer
);
527 Frun_hooks (1, &Qtemp_buffer_setup_hook
);
529 unbind_to (count
, Qnil
);
531 specbind (Qstandard_output
, buf
);
534 static void print (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
);
535 static void print_preprocess (Lisp_Object obj
);
536 static void print_preprocess_string (INTERVAL interval
, Lisp_Object arg
);
537 static void print_object (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
);
539 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
540 doc
: /* Output a newline to stream PRINTCHARFUN.
541 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
542 (Lisp_Object printcharfun
)
546 if (NILP (printcharfun
))
547 printcharfun
= Vstandard_output
;
554 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
555 doc
: /* Output the printed representation of OBJECT, any Lisp object.
556 Quoting characters are printed when needed to make output that `read'
557 can handle, whenever this is possible. For complex objects, the behavior
558 is controlled by `print-level' and `print-length', which see.
560 OBJECT is any of the Lisp data types: a number, a string, a symbol,
561 a list, a buffer, a window, a frame, etc.
563 A printed representation of an object is text which describes that object.
565 Optional argument PRINTCHARFUN is the output stream, which can be one
568 - a buffer, in which case output is inserted into that buffer at point;
569 - a marker, in which case output is inserted at marker's position;
570 - a function, in which case that function is called once for each
571 character of OBJECT's printed representation;
572 - a symbol, in which case that symbol's function definition is called; or
573 - t, in which case the output is displayed in the echo area.
575 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
577 (Lisp_Object object
, Lisp_Object printcharfun
)
581 if (NILP (printcharfun
))
582 printcharfun
= Vstandard_output
;
584 print (object
, printcharfun
, 1);
589 /* a buffer which is used to hold output being built by prin1-to-string */
590 Lisp_Object Vprin1_to_string_buffer
;
592 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
593 doc
: /* Return a string containing the printed representation of OBJECT.
594 OBJECT can be any Lisp object. This function outputs quoting characters
595 when necessary to make output that `read' can handle, whenever possible,
596 unless the optional second argument NOESCAPE is non-nil. For complex objects,
597 the behavior is controlled by `print-level' and `print-length', which see.
599 OBJECT is any of the Lisp data types: a number, a string, a symbol,
600 a list, a buffer, a window, a frame, etc.
602 A printed representation of an object is text which describes that object. */)
603 (Lisp_Object object
, Lisp_Object noescape
)
605 Lisp_Object printcharfun
;
606 /* struct gcpro gcpro1, gcpro2; */
607 Lisp_Object save_deactivate_mark
;
608 int count
= SPECPDL_INDEX ();
609 struct buffer
*previous
;
611 specbind (Qinhibit_modification_hooks
, Qt
);
616 /* Save and restore this--we are altering a buffer
617 but we don't want to deactivate the mark just for that.
618 No need for specbind, since errors deactivate the mark. */
619 save_deactivate_mark
= Vdeactivate_mark
;
620 /* GCPRO2 (object, save_deactivate_mark); */
623 printcharfun
= Vprin1_to_string_buffer
;
625 print (object
, printcharfun
, NILP (noescape
));
626 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
630 previous
= current_buffer
;
631 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
632 object
= Fbuffer_string ();
633 if (SBYTES (object
) == SCHARS (object
))
634 STRING_SET_UNIBYTE (object
);
636 /* Note that this won't make prepare_to_modify_buffer call
637 ask-user-about-supersession-threat because this buffer
638 does not visit a file. */
640 set_buffer_internal (previous
);
642 Vdeactivate_mark
= save_deactivate_mark
;
646 return unbind_to (count
, object
);
649 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
650 doc
: /* Output the printed representation of OBJECT, any Lisp object.
651 No quoting characters are used; no delimiters are printed around
652 the contents of strings.
654 OBJECT is any of the Lisp data types: a number, a string, a symbol,
655 a list, a buffer, a window, a frame, etc.
657 A printed representation of an object is text which describes that object.
659 Optional argument PRINTCHARFUN is the output stream, which can be one
662 - a buffer, in which case output is inserted into that buffer at point;
663 - a marker, in which case output is inserted at marker's position;
664 - a function, in which case that function is called once for each
665 character of OBJECT's printed representation;
666 - a symbol, in which case that symbol's function definition is called; or
667 - t, in which case the output is displayed in the echo area.
669 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
671 (Lisp_Object object
, Lisp_Object printcharfun
)
675 if (NILP (printcharfun
))
676 printcharfun
= Vstandard_output
;
678 print (object
, printcharfun
, 0);
683 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
684 doc
: /* Output the printed representation of OBJECT, with newlines around it.
685 Quoting characters are printed when needed to make output that `read'
686 can handle, whenever this is possible. For complex objects, the behavior
687 is controlled by `print-level' and `print-length', which see.
689 OBJECT is any of the Lisp data types: a number, a string, a symbol,
690 a list, a buffer, a window, a frame, etc.
692 A printed representation of an object is text which describes that object.
694 Optional argument PRINTCHARFUN is the output stream, which can be one
697 - a buffer, in which case output is inserted into that buffer at point;
698 - a marker, in which case output is inserted at marker's position;
699 - a function, in which case that function is called once for each
700 character of OBJECT's printed representation;
701 - a symbol, in which case that symbol's function definition is called; or
702 - t, in which case the output is displayed in the echo area.
704 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
706 (Lisp_Object object
, Lisp_Object printcharfun
)
711 if (NILP (printcharfun
))
712 printcharfun
= Vstandard_output
;
716 print (object
, printcharfun
, 1);
723 /* The subroutine object for external-debugging-output is kept here
724 for the convenience of the debugger. */
725 Lisp_Object Qexternal_debugging_output
;
727 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
728 doc
: /* Write CHARACTER to stderr.
729 You can call print while debugging emacs, and pass it this function
730 to make it write to the debugging output. */)
731 (Lisp_Object character
)
733 CHECK_NUMBER (character
);
734 putc ((int) XINT (character
), stderr
);
737 /* Send the output to a debugger (nothing happens if there isn't one). */
738 if (print_output_debug_flag
)
740 char buf
[2] = {(char) XINT (character
), '\0'};
741 OutputDebugString (buf
);
748 /* This function is never called. Its purpose is to prevent
749 print_output_debug_flag from being optimized away. */
751 extern void debug_output_compilation_hack (int) EXTERNALLY_VISIBLE
;
753 debug_output_compilation_hack (int x
)
755 print_output_debug_flag
= x
;
758 #if defined (GNU_LINUX)
760 /* This functionality is not vitally important in general, so we rely on
761 non-portable ability to use stderr as lvalue. */
763 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
765 static FILE *initial_stderr_stream
= NULL
;
767 DEFUN ("redirect-debugging-output", Fredirect_debugging_output
, Sredirect_debugging_output
,
769 "FDebug output file: \nP",
770 doc
: /* Redirect debugging output (stderr stream) to file FILE.
771 If FILE is nil, reset target to the initial stderr stream.
772 Optional arg APPEND non-nil (interactively, with prefix arg) means
773 append to existing target file. */)
774 (Lisp_Object file
, Lisp_Object append
)
776 if (initial_stderr_stream
!= NULL
)
782 stderr
= initial_stderr_stream
;
783 initial_stderr_stream
= NULL
;
787 file
= Fexpand_file_name (file
, Qnil
);
788 initial_stderr_stream
= stderr
;
789 stderr
= fopen (SSDATA (file
), NILP (append
) ? "w" : "a");
792 stderr
= initial_stderr_stream
;
793 initial_stderr_stream
= NULL
;
794 report_file_error ("Cannot open debugging output stream",
800 #endif /* GNU_LINUX */
803 /* This is the interface for debugging printing. */
806 debug_print (Lisp_Object arg
)
808 Fprin1 (arg
, Qexternal_debugging_output
);
809 fprintf (stderr
, "\r\n");
812 void safe_debug_print (Lisp_Object
) EXTERNALLY_VISIBLE
;
814 safe_debug_print (Lisp_Object arg
)
816 int valid
= valid_lisp_object_p (arg
);
821 fprintf (stderr
, "#<%s_LISP_OBJECT 0x%08"pI
"x>\r\n",
822 !valid
? "INVALID" : "SOME",
827 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
829 doc
: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
830 See Info anchor `(elisp)Definition of signal' for some details on how this
831 error message is constructed. */)
834 struct buffer
*old
= current_buffer
;
838 /* If OBJ is (error STRING), just return STRING.
839 That is not only faster, it also avoids the need to allocate
840 space here when the error is due to memory full. */
841 if (CONSP (obj
) && EQ (XCAR (obj
), Qerror
)
842 && CONSP (XCDR (obj
))
843 && STRINGP (XCAR (XCDR (obj
)))
844 && NILP (XCDR (XCDR (obj
))))
845 return XCAR (XCDR (obj
));
847 print_error_message (obj
, Vprin1_to_string_buffer
, 0, Qnil
);
849 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
850 value
= Fbuffer_string ();
854 set_buffer_internal (old
);
860 /* Print an error message for the error DATA onto Lisp output stream
861 STREAM (suitable for the print functions).
862 CONTEXT is a C string describing the context of the error.
863 CALLER is the Lisp function inside which the error was signaled. */
866 print_error_message (Lisp_Object data
, Lisp_Object stream
, const char *context
,
869 Lisp_Object errname
, errmsg
, file_error
, tail
;
874 write_string_1 (context
, -1, stream
);
876 /* If we know from where the error was signaled, show it in
878 if (!NILP (caller
) && SYMBOLP (caller
))
880 Lisp_Object cname
= SYMBOL_NAME (caller
);
881 char *name
= alloca (SBYTES (cname
));
882 memcpy (name
, SDATA (cname
), SBYTES (cname
));
883 message_dolog (name
, SBYTES (cname
), 0, 0);
884 message_dolog (": ", 2, 0, 0);
887 errname
= Fcar (data
);
889 if (EQ (errname
, Qerror
))
894 errmsg
= Fcar (data
);
899 Lisp_Object error_conditions
;
900 errmsg
= Fget (errname
, Qerror_message
);
901 error_conditions
= Fget (errname
, Qerror_conditions
);
902 file_error
= Fmemq (Qfile_error
, error_conditions
);
905 /* Print an error message including the data items. */
907 tail
= Fcdr_safe (data
);
910 /* For file-error, make error message by concatenating
911 all the data items. They are all strings. */
912 if (!NILP (file_error
) && CONSP (tail
))
913 errmsg
= XCAR (tail
), tail
= XCDR (tail
);
915 if (STRINGP (errmsg
))
916 Fprinc (errmsg
, stream
);
918 write_string_1 ("peculiar error", -1, stream
);
920 for (i
= 0; CONSP (tail
); tail
= XCDR (tail
), i
= 1)
924 write_string_1 (i
? ", " : ": ", 2, stream
);
926 if (!NILP (file_error
) || EQ (errname
, Qend_of_file
))
927 Fprinc (obj
, stream
);
929 Fprin1 (obj
, stream
);
938 * The buffer should be at least as large as the max string size of the
939 * largest float, printed in the biggest notation. This is undoubtedly
940 * 20d float_output_format, with the negative of the C-constant "HUGE"
943 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
945 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
946 * case of -1e307 in 20d float_output_format. What is one to do (short of
947 * re-writing _doprnt to be more sane)?
949 * Given the above, the buffer must be least FLOAT_TO_STRING_BUFSIZE bytes.
953 float_to_string (char *buf
, double data
)
958 /* Check for plus infinity in a way that won't lose
959 if there is no plus infinity. */
960 if (data
== data
/ 2 && data
> 1.0)
962 strcpy (buf
, "1.0e+INF");
965 /* Likewise for minus infinity. */
966 if (data
== data
/ 2 && data
< -1.0)
968 strcpy (buf
, "-1.0e+INF");
971 /* Check for NaN in a way that won't fail if there are no NaNs. */
972 if (! (data
* 0.0 >= 0.0))
974 /* Prepend "-" if the NaN's sign bit is negative.
975 The sign bit of a double is the bit that is 1 in -0.0. */
977 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
979 u_minus_zero
.d
= - 0.0;
980 for (i
= 0; i
< sizeof (double); i
++)
981 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
987 strcpy (buf
, "0.0e+NaN");
991 if (NILP (Vfloat_output_format
)
992 || !STRINGP (Vfloat_output_format
))
995 /* Generate the fewest number of digits that represent the
996 floating point value without losing information. */
997 dtoastr (buf
, FLOAT_TO_STRING_BUFSIZE
- 2, 0, 0, data
);
998 /* The decimal point must be printed, or the byte compiler can
999 get confused (Bug#8033). */
1002 else /* oink oink */
1004 /* Check that the spec we have is fully valid.
1005 This means not only valid for printf,
1006 but meant for floats, and reasonable. */
1007 cp
= SSDATA (Vfloat_output_format
);
1016 /* Check the width specification. */
1018 if ('0' <= *cp
&& *cp
<= '9')
1022 width
= (width
* 10) + (*cp
++ - '0');
1023 while (*cp
>= '0' && *cp
<= '9');
1025 /* A precision of zero is valid only for %f. */
1027 || (width
== 0 && *cp
!= 'f'))
1031 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
1037 sprintf (buf
, SSDATA (Vfloat_output_format
), data
);
1040 /* Make sure there is a decimal point with digit after, or an
1041 exponent, so that the value is readable as a float. But don't do
1042 this with "%.0f"; it's valid for that not to produce a decimal
1043 point. Note that width can be 0 only for %.0f. */
1046 for (cp
= buf
; *cp
; cp
++)
1047 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
1050 if (*cp
== '.' && cp
[1] == 0)
1066 print (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
)
1068 new_backquote_output
= 0;
1070 /* Reset print_number_index and Vprint_number_table only when
1071 the variable Vprint_continuous_numbering is nil. Otherwise,
1072 the values of these variables will be kept between several
1074 if (NILP (Vprint_continuous_numbering
)
1075 || NILP (Vprint_number_table
))
1077 print_number_index
= 0;
1078 Vprint_number_table
= Qnil
;
1081 /* Construct Vprint_number_table for print-gensym and print-circle. */
1082 if (!NILP (Vprint_gensym
) || !NILP (Vprint_circle
))
1084 /* Construct Vprint_number_table.
1085 This increments print_number_index for the objects added. */
1087 print_preprocess (obj
);
1089 if (HASH_TABLE_P (Vprint_number_table
))
1090 { /* Remove unnecessary objects, which appear only once in OBJ;
1091 that is, whose status is Qt.
1092 Maybe a better way to do that is to copy elements to
1093 a new hash table. */
1094 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vprint_number_table
);
1097 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
1098 if (!NILP (HASH_HASH (h
, i
))
1099 && EQ (HASH_VALUE (h
, i
), Qt
))
1100 Fremhash (HASH_KEY (h
, i
), Vprint_number_table
);
1105 print_object (obj
, printcharfun
, escapeflag
);
1108 #define PRINT_CIRCLE_CANDIDATE_P(obj) \
1109 (STRINGP (obj) || CONSP (obj) \
1110 || (VECTORLIKEP (obj) \
1111 && (VECTORP (obj) || COMPILEDP (obj) \
1112 || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \
1113 || HASH_TABLE_P (obj) || FONTP (obj))) \
1114 || (! NILP (Vprint_gensym) \
1116 && !SYMBOL_INTERNED_P (obj)))
1118 /* Construct Vprint_number_table according to the structure of OBJ.
1119 OBJ itself and all its elements will be added to Vprint_number_table
1120 recursively if it is a list, vector, compiled function, char-table,
1121 string (its text properties will be traced), or a symbol that has
1122 no obarray (this is for the print-gensym feature).
1123 The status fields of Vprint_number_table mean whether each object appears
1124 more than once in OBJ: Qnil at the first time, and Qt after that . */
1126 print_preprocess (Lisp_Object obj
)
1131 Lisp_Object halftail
;
1133 /* Give up if we go so deep that print_object will get an error. */
1134 /* See similar code in print_object. */
1135 if (print_depth
>= PRINT_CIRCLE
)
1136 error ("Apparently circular structure being printed");
1138 /* Avoid infinite recursion for circular nested structure
1139 in the case where Vprint_circle is nil. */
1140 if (NILP (Vprint_circle
))
1142 for (i
= 0; i
< print_depth
; i
++)
1143 if (EQ (obj
, being_printed
[i
]))
1145 being_printed
[print_depth
] = obj
;
1152 if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1154 if (!HASH_TABLE_P (Vprint_number_table
))
1156 Lisp_Object args
[2];
1159 Vprint_number_table
= Fmake_hash_table (2, args
);
1162 /* In case print-circle is nil and print-gensym is t,
1163 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1164 if (! NILP (Vprint_circle
) || SYMBOLP (obj
))
1166 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1168 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1169 always print the gensym with a number. This is a special for
1170 the lisp function byte-compile-output-docform. */
1171 || (!NILP (Vprint_continuous_numbering
)
1173 && !SYMBOL_INTERNED_P (obj
)))
1174 { /* OBJ appears more than once. Let's remember that. */
1175 if (!INTEGERP (num
))
1177 print_number_index
++;
1178 /* Negative number indicates it hasn't been printed yet. */
1179 Fputhash (obj
, make_number (- print_number_index
),
1180 Vprint_number_table
);
1186 /* OBJ is not yet recorded. Let's add to the table. */
1187 Fputhash (obj
, Qt
, Vprint_number_table
);
1190 switch (XTYPE (obj
))
1193 /* A string may have text properties, which can be circular. */
1194 traverse_intervals_noorder (STRING_INTERVALS (obj
),
1195 print_preprocess_string
, Qnil
);
1199 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1200 just as in print_object. */
1201 if (loop_count
&& EQ (obj
, halftail
))
1203 print_preprocess (XCAR (obj
));
1206 if (!(loop_count
& 1))
1207 halftail
= XCDR (halftail
);
1210 case Lisp_Vectorlike
:
1212 if (size
& PSEUDOVECTOR_FLAG
)
1213 size
&= PSEUDOVECTOR_SIZE_MASK
;
1214 for (i
= 0; i
< size
; i
++)
1215 print_preprocess (XVECTOR (obj
)->contents
[i
]);
1216 if (HASH_TABLE_P (obj
))
1217 { /* For hash tables, the key_and_value slot is past
1218 `size' because it needs to be marked specially in case
1219 the table is weak. */
1220 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1221 print_preprocess (h
->key_and_value
);
1233 print_preprocess_string (INTERVAL interval
, Lisp_Object arg
)
1235 print_preprocess (interval
->plist
);
1238 static void print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
);
1240 #define PRINT_STRING_NON_CHARSET_FOUND 1
1241 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1243 /* Bitwise or of the above macros. */
1244 static int print_check_string_result
;
1247 print_check_string_charset_prop (INTERVAL interval
, Lisp_Object string
)
1251 if (NILP (interval
->plist
)
1252 || (print_check_string_result
== (PRINT_STRING_NON_CHARSET_FOUND
1253 | PRINT_STRING_UNSAFE_CHARSET_FOUND
)))
1255 for (val
= interval
->plist
; CONSP (val
) && ! EQ (XCAR (val
), Qcharset
);
1256 val
= XCDR (XCDR (val
)));
1259 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1262 if (! (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
))
1264 if (! EQ (val
, interval
->plist
)
1265 || CONSP (XCDR (XCDR (val
))))
1266 print_check_string_result
|= PRINT_STRING_NON_CHARSET_FOUND
;
1268 if (NILP (Vprint_charset_text_property
)
1269 || ! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1272 EMACS_INT charpos
= interval
->position
;
1273 EMACS_INT bytepos
= string_char_to_byte (string
, charpos
);
1274 Lisp_Object charset
;
1276 charset
= XCAR (XCDR (val
));
1277 for (i
= 0; i
< LENGTH (interval
); i
++)
1279 FETCH_STRING_CHAR_ADVANCE (c
, string
, charpos
, bytepos
);
1280 if (! ASCII_CHAR_P (c
)
1281 && ! EQ (CHARSET_NAME (CHAR_CHARSET (c
)), charset
))
1283 print_check_string_result
|= PRINT_STRING_UNSAFE_CHARSET_FOUND
;
1290 /* The value is (charset . nil). */
1291 static Lisp_Object print_prune_charset_plist
;
1294 print_prune_string_charset (Lisp_Object string
)
1296 print_check_string_result
= 0;
1297 traverse_intervals (STRING_INTERVALS (string
), 0,
1298 print_check_string_charset_prop
, string
);
1299 if (! (print_check_string_result
& PRINT_STRING_UNSAFE_CHARSET_FOUND
))
1301 string
= Fcopy_sequence (string
);
1302 if (print_check_string_result
& PRINT_STRING_NON_CHARSET_FOUND
)
1304 if (NILP (print_prune_charset_plist
))
1305 print_prune_charset_plist
= Fcons (Qcharset
, Qnil
);
1306 Fremove_text_properties (make_number (0),
1307 make_number (SCHARS (string
)),
1308 print_prune_charset_plist
, string
);
1311 Fset_text_properties (make_number (0), make_number (SCHARS (string
)),
1318 print_object (Lisp_Object obj
, register Lisp_Object printcharfun
, int escapeflag
)
1324 /* See similar code in print_preprocess. */
1325 if (print_depth
>= PRINT_CIRCLE
)
1326 error ("Apparently circular structure being printed");
1328 /* Detect circularities and truncate them. */
1329 if (PRINT_CIRCLE_CANDIDATE_P (obj
))
1331 if (NILP (Vprint_circle
) && NILP (Vprint_gensym
))
1333 /* Simple but incomplete way. */
1335 for (i
= 0; i
< print_depth
; i
++)
1336 if (EQ (obj
, being_printed
[i
]))
1338 sprintf (buf
, "#%d", i
);
1339 strout (buf
, -1, -1, printcharfun
);
1342 being_printed
[print_depth
] = obj
;
1346 /* With the print-circle feature. */
1347 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1350 EMACS_INT n
= XINT (num
);
1352 { /* Add a prefix #n= if OBJ has not yet been printed;
1353 that is, its status field is nil. */
1354 sprintf (buf
, "#%"pI
"d=", -n
);
1355 strout (buf
, -1, -1, printcharfun
);
1356 /* OBJ is going to be printed. Remember that fact. */
1357 Fputhash (obj
, make_number (- n
), Vprint_number_table
);
1361 /* Just print #n# if OBJ has already been printed. */
1362 sprintf (buf
, "#%"pI
"d#", n
);
1363 strout (buf
, -1, -1, printcharfun
);
1372 switch (XTYPE (obj
))
1375 sprintf (buf
, "%"pI
"d", XINT (obj
));
1376 strout (buf
, -1, -1, printcharfun
);
1381 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
1383 float_to_string (pigbuf
, XFLOAT_DATA (obj
));
1384 strout (pigbuf
, -1, -1, printcharfun
);
1390 print_string (obj
, printcharfun
);
1393 register EMACS_INT i_byte
;
1394 struct gcpro gcpro1
;
1396 EMACS_INT size_byte
;
1397 /* 1 means we must ensure that the next character we output
1398 cannot be taken as part of a hex character escape. */
1399 int need_nonhex
= 0;
1400 int multibyte
= STRING_MULTIBYTE (obj
);
1404 if (! EQ (Vprint_charset_text_property
, Qt
))
1405 obj
= print_prune_string_charset (obj
);
1407 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1415 size_byte
= SBYTES (obj
);
1417 for (i_byte
= 0; i_byte
< size_byte
;)
1419 /* Here, we must convert each multi-byte form to the
1420 corresponding character code before handing it to PRINTCHAR. */
1426 c
= STRING_CHAR_AND_LENGTH (str
+ i_byte
, len
);
1434 if (c
== '\n' && print_escape_newlines
)
1439 else if (c
== '\f' && print_escape_newlines
)
1445 && (CHAR_BYTE8_P (c
)
1446 || (! ASCII_CHAR_P (c
) && print_escape_multibyte
)))
1448 /* When multibyte is disabled,
1449 print multibyte string chars using hex escapes.
1450 For a char code that could be in a unibyte string,
1451 when found in a multibyte string, always use a hex escape
1452 so it reads back as multibyte. */
1455 if (CHAR_BYTE8_P (c
))
1456 sprintf (outbuf
, "\\%03o", CHAR_TO_BYTE8 (c
));
1459 sprintf (outbuf
, "\\x%04x", c
);
1462 strout (outbuf
, -1, -1, printcharfun
);
1464 else if (! multibyte
1465 && SINGLE_BYTE_CHAR_P (c
) && ! ASCII_BYTE_P (c
)
1466 && print_escape_nonascii
)
1468 /* When printing in a multibyte buffer
1469 or when explicitly requested,
1470 print single-byte non-ASCII string chars
1471 using octal escapes. */
1473 sprintf (outbuf
, "\\%03o", c
);
1474 strout (outbuf
, -1, -1, printcharfun
);
1478 /* If we just had a hex escape, and this character
1479 could be taken as part of it,
1480 output `\ ' to prevent that. */
1484 if ((c
>= 'a' && c
<= 'f')
1485 || (c
>= 'A' && c
<= 'F')
1486 || (c
>= '0' && c
<= '9'))
1487 strout ("\\ ", -1, -1, printcharfun
);
1490 if (c
== '\"' || c
== '\\')
1497 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj
)))
1499 traverse_intervals (STRING_INTERVALS (obj
),
1500 0, print_interval
, printcharfun
);
1510 register int confusing
;
1511 register unsigned char *p
= SDATA (SYMBOL_NAME (obj
));
1512 register unsigned char *end
= p
+ SBYTES (SYMBOL_NAME (obj
));
1515 EMACS_INT size_byte
;
1518 name
= SYMBOL_NAME (obj
);
1520 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
1523 /* If symbol name begins with a digit, and ends with a digit,
1524 and contains nothing but digits and `e', it could be treated
1525 as a number. So set CONFUSING.
1527 Symbols that contain periods could also be taken as numbers,
1528 but periods are always escaped, so we don't have to worry
1530 else if (*p
>= '0' && *p
<= '9'
1531 && end
[-1] >= '0' && end
[-1] <= '9')
1533 while (p
!= end
&& ((*p
>= '0' && *p
<= '9')
1534 /* Needed for \2e10. */
1535 || *p
== 'e' || *p
== 'E'))
1537 confusing
= (end
== p
);
1542 if (! NILP (Vprint_gensym
) && !SYMBOL_INTERNED_P (obj
))
1548 size_byte
= SBYTES (name
);
1550 for (i
= 0, i_byte
= 0; i_byte
< size_byte
;)
1552 /* Here, we must convert each multi-byte form to the
1553 corresponding character code before handing it to PRINTCHAR. */
1554 FETCH_STRING_CHAR_ADVANCE (c
, name
, i
, i_byte
);
1559 if (c
== '\"' || c
== '\\' || c
== '\''
1560 || c
== ';' || c
== '#' || c
== '(' || c
== ')'
1561 || c
== ',' || c
=='.' || c
== '`'
1562 || c
== '[' || c
== ']' || c
== '?' || c
<= 040
1564 PRINTCHAR ('\\'), confusing
= 0;
1572 /* If deeper than spec'd depth, print placeholder. */
1573 if (INTEGERP (Vprint_level
)
1574 && print_depth
> XINT (Vprint_level
))
1575 strout ("...", -1, -1, printcharfun
);
1576 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1577 && (EQ (XCAR (obj
), Qquote
)))
1580 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1582 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1583 && (EQ (XCAR (obj
), Qfunction
)))
1587 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1589 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1590 && ((EQ (XCAR (obj
), Qbackquote
))))
1592 print_object (XCAR (obj
), printcharfun
, 0);
1593 new_backquote_output
++;
1594 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1595 new_backquote_output
--;
1597 else if (print_quoted
&& CONSP (XCDR (obj
)) && NILP (XCDR (XCDR (obj
)))
1598 && new_backquote_output
1599 && ((EQ (XCAR (obj
), Qbackquote
)
1600 || EQ (XCAR (obj
), Qcomma
)
1601 || EQ (XCAR (obj
), Qcomma_at
)
1602 || EQ (XCAR (obj
), Qcomma_dot
))))
1604 print_object (XCAR (obj
), printcharfun
, 0);
1605 new_backquote_output
--;
1606 print_object (XCAR (XCDR (obj
)), printcharfun
, escapeflag
);
1607 new_backquote_output
++;
1614 EMACS_INT print_length
;
1616 Lisp_Object halftail
= obj
;
1618 /* Negative values of print-length are invalid in CL.
1619 Treat them like nil, as CMUCL does. */
1620 if (NATNUMP (Vprint_length
))
1621 print_length
= XFASTINT (Vprint_length
);
1628 /* Detect circular list. */
1629 if (NILP (Vprint_circle
))
1631 /* Simple but imcomplete way. */
1632 if (i
!= 0 && EQ (obj
, halftail
))
1634 sprintf (buf
, " . #%d", i
/ 2);
1635 strout (buf
, -1, -1, printcharfun
);
1641 /* With the print-circle feature. */
1644 Lisp_Object num
= Fgethash (obj
, Vprint_number_table
, Qnil
);
1647 strout (" . ", 3, 3, printcharfun
);
1648 print_object (obj
, printcharfun
, escapeflag
);
1657 if (print_length
&& i
> print_length
)
1659 strout ("...", 3, 3, printcharfun
);
1663 print_object (XCAR (obj
), printcharfun
, escapeflag
);
1667 halftail
= XCDR (halftail
);
1671 /* OBJ non-nil here means it's the end of a dotted list. */
1674 strout (" . ", 3, 3, printcharfun
);
1675 print_object (obj
, printcharfun
, escapeflag
);
1683 case Lisp_Vectorlike
:
1688 strout ("#<process ", -1, -1, printcharfun
);
1689 print_string (XPROCESS (obj
)->name
, printcharfun
);
1693 print_string (XPROCESS (obj
)->name
, printcharfun
);
1695 else if (BOOL_VECTOR_P (obj
))
1698 register unsigned char c
;
1699 struct gcpro gcpro1
;
1700 EMACS_INT size_in_chars
1701 = ((XBOOL_VECTOR (obj
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
1702 / BOOL_VECTOR_BITS_PER_CHAR
);
1708 sprintf (buf
, "%"pI
"d", XBOOL_VECTOR (obj
)->size
);
1709 strout (buf
, -1, -1, printcharfun
);
1712 /* Don't print more characters than the specified maximum.
1713 Negative values of print-length are invalid. Treat them
1714 like a print-length of nil. */
1715 if (NATNUMP (Vprint_length
)
1716 && XFASTINT (Vprint_length
) < size_in_chars
)
1717 size_in_chars
= XFASTINT (Vprint_length
);
1719 for (i
= 0; i
< size_in_chars
; i
++)
1722 c
= XBOOL_VECTOR (obj
)->data
[i
];
1723 if (c
== '\n' && print_escape_newlines
)
1728 else if (c
== '\f' && print_escape_newlines
)
1733 else if (c
> '\177')
1735 /* Use octal escapes to avoid encoding issues. */
1737 PRINTCHAR ('0' + ((c
>> 6) & 3));
1738 PRINTCHAR ('0' + ((c
>> 3) & 7));
1739 PRINTCHAR ('0' + (c
& 7));
1743 if (c
== '\"' || c
== '\\')
1752 else if (SUBRP (obj
))
1754 strout ("#<subr ", -1, -1, printcharfun
);
1755 strout (XSUBR (obj
)->symbol_name
, -1, -1, printcharfun
);
1758 else if (WINDOWP (obj
))
1760 strout ("#<window ", -1, -1, printcharfun
);
1761 sprintf (buf
, "%"pI
"d", XFASTINT (XWINDOW (obj
)->sequence_number
));
1762 strout (buf
, -1, -1, printcharfun
);
1763 if (!NILP (XWINDOW (obj
)->buffer
))
1765 strout (" on ", -1, -1, printcharfun
);
1766 print_string (BVAR (XBUFFER (XWINDOW (obj
)->buffer
), name
), printcharfun
);
1770 else if (TERMINALP (obj
))
1772 struct terminal
*t
= XTERMINAL (obj
);
1773 strout ("#<terminal ", -1, -1, printcharfun
);
1774 sprintf (buf
, "%d", t
->id
);
1775 strout (buf
, -1, -1, printcharfun
);
1778 strout (" on ", -1, -1, printcharfun
);
1779 strout (t
->name
, -1, -1, printcharfun
);
1783 else if (HASH_TABLE_P (obj
))
1785 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
1787 EMACS_INT real_size
, size
;
1789 strout ("#<hash-table", -1, -1, printcharfun
);
1790 if (SYMBOLP (h
->test
))
1794 strout (SDATA (SYMBOL_NAME (h
->test
)), -1, -1, printcharfun
);
1796 strout (SDATA (SYMBOL_NAME (h
->weak
)), -1, -1, printcharfun
);
1798 sprintf (buf
, "%ld/%ld", (long) h
->count
,
1799 (long) ASIZE (h
->next
));
1800 strout (buf
, -1, -1, printcharfun
);
1802 sprintf (buf
, " 0x%lx", (unsigned long) h
);
1803 strout (buf
, -1, -1, printcharfun
);
1806 /* Implement a readable output, e.g.:
1807 #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
1808 /* Always print the size. */
1809 sprintf (buf
, "#s(hash-table size %ld",
1810 (long) ASIZE (h
->next
));
1811 strout (buf
, -1, -1, printcharfun
);
1813 if (!NILP (h
->test
))
1815 strout (" test ", -1, -1, printcharfun
);
1816 print_object (h
->test
, printcharfun
, escapeflag
);
1819 if (!NILP (h
->weak
))
1821 strout (" weakness ", -1, -1, printcharfun
);
1822 print_object (h
->weak
, printcharfun
, escapeflag
);
1825 if (!NILP (h
->rehash_size
))
1827 strout (" rehash-size ", -1, -1, printcharfun
);
1828 print_object (h
->rehash_size
, printcharfun
, escapeflag
);
1831 if (!NILP (h
->rehash_threshold
))
1833 strout (" rehash-threshold ", -1, -1, printcharfun
);
1834 print_object (h
->rehash_threshold
, printcharfun
, escapeflag
);
1837 strout (" data ", -1, -1, printcharfun
);
1839 /* Print the data here as a plist. */
1840 real_size
= HASH_TABLE_SIZE (h
);
1843 /* Don't print more elements than the specified maximum. */
1844 if (NATNUMP (Vprint_length
)
1845 && XFASTINT (Vprint_length
) < size
)
1846 size
= XFASTINT (Vprint_length
);
1849 for (i
= 0; i
< size
; i
++)
1850 if (!NILP (HASH_HASH (h
, i
)))
1852 if (i
) PRINTCHAR (' ');
1853 print_object (HASH_KEY (h
, i
), printcharfun
, escapeflag
);
1855 print_object (HASH_VALUE (h
, i
), printcharfun
, escapeflag
);
1858 if (size
< real_size
)
1859 strout (" ...", 4, 4, printcharfun
);
1865 else if (BUFFERP (obj
))
1867 if (NILP (BVAR (XBUFFER (obj
), name
)))
1868 strout ("#<killed buffer>", -1, -1, printcharfun
);
1869 else if (escapeflag
)
1871 strout ("#<buffer ", -1, -1, printcharfun
);
1872 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1876 print_string (BVAR (XBUFFER (obj
), name
), printcharfun
);
1878 else if (WINDOW_CONFIGURATIONP (obj
))
1880 strout ("#<window-configuration>", -1, -1, printcharfun
);
1882 else if (FRAMEP (obj
))
1884 strout ((FRAME_LIVE_P (XFRAME (obj
))
1885 ? "#<frame " : "#<dead frame "),
1886 -1, -1, printcharfun
);
1887 print_string (XFRAME (obj
)->name
, printcharfun
);
1888 sprintf (buf
, " %p", XFRAME (obj
));
1889 strout (buf
, -1, -1, printcharfun
);
1892 else if (FONTP (obj
))
1896 if (! FONT_OBJECT_P (obj
))
1898 if (FONT_SPEC_P (obj
))
1899 strout ("#<font-spec", -1, -1, printcharfun
);
1901 strout ("#<font-entity", -1, -1, printcharfun
);
1902 for (i
= 0; i
< FONT_SPEC_MAX
; i
++)
1905 if (i
< FONT_WEIGHT_INDEX
|| i
> FONT_WIDTH_INDEX
)
1906 print_object (AREF (obj
, i
), printcharfun
, escapeflag
);
1908 print_object (font_style_symbolic (obj
, i
, 0),
1909 printcharfun
, escapeflag
);
1914 strout ("#<font-object ", -1, -1, printcharfun
);
1915 print_object (AREF (obj
, FONT_NAME_INDEX
), printcharfun
,
1922 EMACS_INT size
= ASIZE (obj
);
1923 if (COMPILEDP (obj
))
1926 size
&= PSEUDOVECTOR_SIZE_MASK
;
1928 if (CHAR_TABLE_P (obj
) || SUB_CHAR_TABLE_P (obj
))
1930 /* We print a char-table as if it were a vector,
1931 lumping the parent and default slots in with the
1932 character slots. But we add #^ as a prefix. */
1934 /* Make each lowest sub_char_table start a new line.
1935 Otherwise we'll make a line extremely long, which
1936 results in slow redisplay. */
1937 if (SUB_CHAR_TABLE_P (obj
)
1938 && XINT (XSUB_CHAR_TABLE (obj
)->depth
) == 3)
1942 if (SUB_CHAR_TABLE_P (obj
))
1944 size
&= PSEUDOVECTOR_SIZE_MASK
;
1946 if (size
& PSEUDOVECTOR_FLAG
)
1952 register Lisp_Object tem
;
1953 EMACS_INT real_size
= size
;
1955 /* Don't print more elements than the specified maximum. */
1956 if (NATNUMP (Vprint_length
)
1957 && XFASTINT (Vprint_length
) < size
)
1958 size
= XFASTINT (Vprint_length
);
1960 for (i
= 0; i
< size
; i
++)
1962 if (i
) PRINTCHAR (' ');
1963 tem
= XVECTOR (obj
)->contents
[i
];
1964 print_object (tem
, printcharfun
, escapeflag
);
1966 if (size
< real_size
)
1967 strout (" ...", 4, 4, printcharfun
);
1974 switch (XMISCTYPE (obj
))
1976 case Lisp_Misc_Marker
:
1977 strout ("#<marker ", -1, -1, printcharfun
);
1978 /* Do you think this is necessary? */
1979 if (XMARKER (obj
)->insertion_type
!= 0)
1980 strout ("(moves after insertion) ", -1, -1, printcharfun
);
1981 if (! XMARKER (obj
)->buffer
)
1982 strout ("in no buffer", -1, -1, printcharfun
);
1985 sprintf (buf
, "at %"pI
"d", marker_position (obj
));
1986 strout (buf
, -1, -1, printcharfun
);
1987 strout (" in ", -1, -1, printcharfun
);
1988 print_string (BVAR (XMARKER (obj
)->buffer
, name
), printcharfun
);
1993 case Lisp_Misc_Overlay
:
1994 strout ("#<overlay ", -1, -1, printcharfun
);
1995 if (! XMARKER (OVERLAY_START (obj
))->buffer
)
1996 strout ("in no buffer", -1, -1, printcharfun
);
1999 sprintf (buf
, "from %"pI
"d to %"pI
"d in ",
2000 marker_position (OVERLAY_START (obj
)),
2001 marker_position (OVERLAY_END (obj
)));
2002 strout (buf
, -1, -1, printcharfun
);
2003 print_string (BVAR (XMARKER (OVERLAY_START (obj
))->buffer
, name
),
2009 /* Remaining cases shouldn't happen in normal usage, but let's print
2010 them anyway for the benefit of the debugger. */
2011 case Lisp_Misc_Free
:
2012 strout ("#<misc free cell>", -1, -1, printcharfun
);
2015 case Lisp_Misc_Save_Value
:
2016 strout ("#<save_value ", -1, -1, printcharfun
);
2017 sprintf(buf
, "ptr=%p int=%"pD
"d",
2018 XSAVE_VALUE (obj
)->pointer
,
2019 XSAVE_VALUE (obj
)->integer
);
2020 strout (buf
, -1, -1, printcharfun
);
2032 /* We're in trouble if this happens!
2033 Probably should just abort () */
2034 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun
);
2036 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
2037 else if (VECTORLIKEP (obj
))
2038 sprintf (buf
, "(PVEC 0x%08lx)", (unsigned long) ASIZE (obj
));
2040 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
2041 strout (buf
, -1, -1, printcharfun
);
2042 strout (" Save your buffers immediately and please report this bug>",
2043 -1, -1, printcharfun
);
2051 /* Print a description of INTERVAL using PRINTCHARFUN.
2052 This is part of printing a string that has text properties. */
2055 print_interval (INTERVAL interval
, Lisp_Object printcharfun
)
2057 if (NILP (interval
->plist
))
2060 print_object (make_number (interval
->position
), printcharfun
, 1);
2062 print_object (make_number (interval
->position
+ LENGTH (interval
)),
2065 print_object (interval
->plist
, printcharfun
, 1);
2070 syms_of_print (void)
2072 Qtemp_buffer_setup_hook
= intern_c_string ("temp-buffer-setup-hook");
2073 staticpro (&Qtemp_buffer_setup_hook
);
2075 DEFVAR_LISP ("standard-output", Vstandard_output
,
2076 doc
: /* Output stream `print' uses by default for outputting a character.
2077 This may be any function of one argument.
2078 It may also be a buffer (output is inserted before point)
2079 or a marker (output is inserted and the marker is advanced)
2080 or the symbol t (output appears in the echo area). */);
2081 Vstandard_output
= Qt
;
2082 Qstandard_output
= intern_c_string ("standard-output");
2083 staticpro (&Qstandard_output
);
2085 DEFVAR_LISP ("float-output-format", Vfloat_output_format
,
2086 doc
: /* The format descriptor string used to print floats.
2087 This is a %-spec like those accepted by `printf' in C,
2088 but with some restrictions. It must start with the two characters `%.'.
2089 After that comes an integer precision specification,
2090 and then a letter which controls the format.
2091 The letters allowed are `e', `f' and `g'.
2092 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2093 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2094 Use `g' to choose the shorter of those two formats for the number at hand.
2095 The precision in any of these cases is the number of digits following
2096 the decimal point. With `f', a precision of 0 means to omit the
2097 decimal point. 0 is not allowed with `e' or `g'.
2099 A value of nil means to use the shortest notation
2100 that represents the number without losing information. */);
2101 Vfloat_output_format
= Qnil
;
2102 Qfloat_output_format
= intern_c_string ("float-output-format");
2103 staticpro (&Qfloat_output_format
);
2105 DEFVAR_LISP ("print-length", Vprint_length
,
2106 doc
: /* Maximum length of list to print before abbreviating.
2107 A value of nil means no limit. See also `eval-expression-print-length'. */);
2108 Vprint_length
= Qnil
;
2110 DEFVAR_LISP ("print-level", Vprint_level
,
2111 doc
: /* Maximum depth of list nesting to print before abbreviating.
2112 A value of nil means no limit. See also `eval-expression-print-level'. */);
2113 Vprint_level
= Qnil
;
2115 DEFVAR_BOOL ("print-escape-newlines", print_escape_newlines
,
2116 doc
: /* Non-nil means print newlines in strings as `\\n'.
2117 Also print formfeeds as `\\f'. */);
2118 print_escape_newlines
= 0;
2120 DEFVAR_BOOL ("print-escape-nonascii", print_escape_nonascii
,
2121 doc
: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2122 \(OOO is the octal representation of the character code.)
2123 Only single-byte characters are affected, and only in `prin1'.
2124 When the output goes in a multibyte buffer, this feature is
2125 enabled regardless of the value of the variable. */);
2126 print_escape_nonascii
= 0;
2128 DEFVAR_BOOL ("print-escape-multibyte", print_escape_multibyte
,
2129 doc
: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2130 \(XXXX is the hex representation of the character code.)
2131 This affects only `prin1'. */);
2132 print_escape_multibyte
= 0;
2134 DEFVAR_BOOL ("print-quoted", print_quoted
,
2135 doc
: /* Non-nil means print quoted forms with reader syntax.
2136 I.e., (quote foo) prints as 'foo, (function foo) as #'foo. */);
2139 DEFVAR_LISP ("print-gensym", Vprint_gensym
,
2140 doc
: /* Non-nil means print uninterned symbols so they will read as uninterned.
2141 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2142 When the uninterned symbol appears within a recursive data structure,
2143 and the symbol appears more than once, in addition use the #N# and #N=
2144 constructs as needed, so that multiple references to the same symbol are
2145 shared once again when the text is read back. */);
2146 Vprint_gensym
= Qnil
;
2148 DEFVAR_LISP ("print-circle", Vprint_circle
,
2149 doc
: /* *Non-nil means print recursive structures using #N= and #N# syntax.
2150 If nil, printing proceeds recursively and may lead to
2151 `max-lisp-eval-depth' being exceeded or an error may occur:
2152 \"Apparently circular structure being printed.\" Also see
2153 `print-length' and `print-level'.
2154 If non-nil, shared substructures anywhere in the structure are printed
2155 with `#N=' before the first occurrence (in the order of the print
2156 representation) and `#N#' in place of each subsequent occurrence,
2157 where N is a positive decimal integer. */);
2158 Vprint_circle
= Qnil
;
2160 DEFVAR_LISP ("print-continuous-numbering", Vprint_continuous_numbering
,
2161 doc
: /* *Non-nil means number continuously across print calls.
2162 This affects the numbers printed for #N= labels and #M# references.
2163 See also `print-circle', `print-gensym', and `print-number-table'.
2164 This variable should not be set with `setq'; bind it with a `let' instead. */);
2165 Vprint_continuous_numbering
= Qnil
;
2167 DEFVAR_LISP ("print-number-table", Vprint_number_table
,
2168 doc
: /* A vector used internally to produce `#N=' labels and `#N#' references.
2169 The Lisp printer uses this vector to detect Lisp objects referenced more
2172 When you bind `print-continuous-numbering' to t, you should probably
2173 also bind `print-number-table' to nil. This ensures that the value of
2174 `print-number-table' can be garbage-collected once the printing is
2175 done. If all elements of `print-number-table' are nil, it means that
2176 the printing done so far has not found any shared structure or objects
2177 that need to be recorded in the table. */);
2178 Vprint_number_table
= Qnil
;
2180 DEFVAR_LISP ("print-charset-text-property", Vprint_charset_text_property
,
2181 doc
: /* A flag to control printing of `charset' text property on printing a string.
2182 The value must be nil, t, or `default'.
2184 If the value is nil, don't print the text property `charset'.
2186 If the value is t, always print the text property `charset'.
2188 If the value is `default', print the text property `charset' only when
2189 the value is different from what is guessed in the current charset
2191 Vprint_charset_text_property
= Qdefault
;
2193 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2194 staticpro (&Vprin1_to_string_buffer
);
2197 defsubr (&Sprin1_to_string
);
2198 defsubr (&Serror_message_string
);
2202 defsubr (&Swrite_char
);
2203 defsubr (&Sexternal_debugging_output
);
2204 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2205 defsubr (&Sredirect_debugging_output
);
2208 Qexternal_debugging_output
= intern_c_string ("external-debugging-output");
2209 staticpro (&Qexternal_debugging_output
);
2211 Qprint_escape_newlines
= intern_c_string ("print-escape-newlines");
2212 staticpro (&Qprint_escape_newlines
);
2214 Qprint_escape_multibyte
= intern_c_string ("print-escape-multibyte");
2215 staticpro (&Qprint_escape_multibyte
);
2217 Qprint_escape_nonascii
= intern_c_string ("print-escape-nonascii");
2218 staticpro (&Qprint_escape_nonascii
);
2220 print_prune_charset_plist
= Qnil
;
2221 staticpro (&print_prune_charset_plist
);