Revert previous patch, it introduces other problems.
[emacs.git] / src / print.c
blob475be9ec28542c213462367dfe43835a90adbb25
1 /* Lisp object printing and output streams.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2014 Free Software
4 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/>. */
22 #include <config.h>
23 #include "sysstdio.h"
25 #include "lisp.h"
26 #include "character.h"
27 #include "buffer.h"
28 #include "charset.h"
29 #include "keyboard.h"
30 #include "frame.h"
31 #include "window.h"
32 #include "process.h"
33 #include "dispextern.h"
34 #include "termchar.h"
35 #include "intervals.h"
36 #include "blockinput.h"
37 #include "termhooks.h" /* For struct terminal. */
38 #include "font.h"
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;
48 #include <float.h>
49 #include <ftoastr.h>
51 /* Avoid actual stack overflow in print. */
52 static ptrdiff_t print_depth;
54 /* Level of nesting inside outputting backquote in new style. */
55 static ptrdiff_t new_backquote_output;
57 /* Detect most circularities to print finite output. */
58 #define PRINT_CIRCLE 200
59 static Lisp_Object being_printed[PRINT_CIRCLE];
61 /* When printing into a buffer, first we put the text in this
62 block, then insert it all at once. */
63 static char *print_buffer;
65 /* Size allocated in print_buffer. */
66 static ptrdiff_t print_buffer_size;
67 /* Chars stored in print_buffer. */
68 static ptrdiff_t print_buffer_pos;
69 /* Bytes stored in print_buffer. */
70 static ptrdiff_t print_buffer_pos_byte;
72 Lisp_Object Qprint_escape_newlines;
73 static Lisp_Object Qprint_escape_multibyte, Qprint_escape_nonascii;
75 /* Vprint_number_table is a table, that keeps objects that are going to
76 be printed, to allow use of #n= and #n# to express sharing.
77 For any given object, the table can give the following values:
78 t the object will be printed only once.
79 -N the object will be printed several times and will take number N.
80 N the object has been printed so we can refer to it as #N#.
81 print_number_index holds the largest N already used.
82 N has to be striclty larger than 0 since we need to distinguish -N. */
83 static ptrdiff_t print_number_index;
84 static void print_interval (INTERVAL interval, Lisp_Object printcharfun);
86 /* GDB resets this to zero on W32 to disable OutputDebugString calls. */
87 bool print_output_debug_flag EXTERNALLY_VISIBLE = 1;
90 /* Low level output routines for characters and strings. */
92 /* Lisp functions to do output using a stream
93 must have the stream in a variable called printcharfun
94 and must start with PRINTPREPARE, end with PRINTFINISH,
95 and use PRINTDECLARE to declare common variables.
96 Use PRINTCHAR to output one character,
97 or call strout to output a block of characters. */
99 #define PRINTDECLARE \
100 struct buffer *old = current_buffer; \
101 ptrdiff_t old_point = -1, start_point = -1; \
102 ptrdiff_t old_point_byte = -1, start_point_byte = -1; \
103 ptrdiff_t specpdl_count = SPECPDL_INDEX (); \
104 bool free_print_buffer = 0; \
105 bool multibyte \
106 = !NILP (BVAR (current_buffer, enable_multibyte_characters)); \
107 Lisp_Object original
109 #define PRINTPREPARE \
110 original = printcharfun; \
111 if (NILP (printcharfun)) printcharfun = Qt; \
112 if (BUFFERP (printcharfun)) \
114 if (XBUFFER (printcharfun) != current_buffer) \
115 Fset_buffer (printcharfun); \
116 printcharfun = Qnil; \
118 if (MARKERP (printcharfun)) \
120 ptrdiff_t marker_pos; \
121 if (! XMARKER (printcharfun)->buffer) \
122 error ("Marker does not point anywhere"); \
123 if (XMARKER (printcharfun)->buffer != current_buffer) \
124 set_buffer_internal (XMARKER (printcharfun)->buffer); \
125 marker_pos = marker_position (printcharfun); \
126 if (marker_pos < BEGV || marker_pos > ZV) \
127 signal_error ("Marker is outside the accessible " \
128 "part of the buffer", printcharfun); \
129 old_point = PT; \
130 old_point_byte = PT_BYTE; \
131 SET_PT_BOTH (marker_pos, \
132 marker_byte_position (printcharfun)); \
133 start_point = PT; \
134 start_point_byte = PT_BYTE; \
135 printcharfun = Qnil; \
137 if (NILP (printcharfun)) \
139 Lisp_Object string; \
140 if (NILP (BVAR (current_buffer, enable_multibyte_characters)) \
141 && ! print_escape_multibyte) \
142 specbind (Qprint_escape_multibyte, Qt); \
143 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)) \
144 && ! print_escape_nonascii) \
145 specbind (Qprint_escape_nonascii, Qt); \
146 if (print_buffer != 0) \
148 string = make_string_from_bytes (print_buffer, \
149 print_buffer_pos, \
150 print_buffer_pos_byte); \
151 record_unwind_protect (print_unwind, string); \
153 else \
155 int new_size = 1000; \
156 print_buffer = xmalloc (new_size); \
157 print_buffer_size = new_size; \
158 free_print_buffer = 1; \
160 print_buffer_pos = 0; \
161 print_buffer_pos_byte = 0; \
163 if (EQ (printcharfun, Qt) && ! noninteractive) \
164 setup_echo_area_for_printing (multibyte);
166 #define PRINTFINISH \
167 if (NILP (printcharfun)) \
169 if (print_buffer_pos != print_buffer_pos_byte \
170 && NILP (BVAR (current_buffer, enable_multibyte_characters)))\
172 unsigned char *temp = alloca (print_buffer_pos + 1); \
173 copy_text ((unsigned char *) print_buffer, temp, \
174 print_buffer_pos_byte, 1, 0); \
175 insert_1_both ((char *) temp, print_buffer_pos, \
176 print_buffer_pos, 0, 1, 0); \
178 else \
179 insert_1_both (print_buffer, print_buffer_pos, \
180 print_buffer_pos_byte, 0, 1, 0); \
181 signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
183 if (free_print_buffer) \
185 xfree (print_buffer); \
186 print_buffer = 0; \
188 unbind_to (specpdl_count, Qnil); \
189 if (MARKERP (original)) \
190 set_marker_both (original, Qnil, PT, PT_BYTE); \
191 if (old_point >= 0) \
192 SET_PT_BOTH (old_point + (old_point >= start_point \
193 ? PT - start_point : 0), \
194 old_point_byte + (old_point_byte >= start_point_byte \
195 ? PT_BYTE - start_point_byte : 0)); \
196 set_buffer_internal (old);
198 #define PRINTCHAR(ch) printchar (ch, printcharfun)
200 /* This is used to restore the saved contents of print_buffer
201 when there is a recursive call to print. */
203 static void
204 print_unwind (Lisp_Object saved_text)
206 memcpy (print_buffer, SDATA (saved_text), SCHARS (saved_text));
210 /* Print character CH using method FUN. FUN nil means print to
211 print_buffer. FUN t means print to echo area or stdout if
212 non-interactive. If FUN is neither nil nor t, call FUN with CH as
213 argument. */
215 static void
216 printchar (unsigned int ch, Lisp_Object fun)
218 if (!NILP (fun) && !EQ (fun, Qt))
219 call1 (fun, make_number (ch));
220 else
222 unsigned char str[MAX_MULTIBYTE_LENGTH];
223 int len = CHAR_STRING (ch, str);
225 QUIT;
227 if (NILP (fun))
229 ptrdiff_t incr = len - (print_buffer_size - print_buffer_pos_byte);
230 if (incr > 0)
231 print_buffer = xpalloc (print_buffer, &print_buffer_size,
232 incr, -1, 1);
233 memcpy (print_buffer + print_buffer_pos_byte, str, len);
234 print_buffer_pos += 1;
235 print_buffer_pos_byte += len;
237 else if (noninteractive)
239 fwrite (str, 1, len, stdout);
240 noninteractive_need_newline = 1;
242 else
244 bool multibyte_p
245 = !NILP (BVAR (current_buffer, enable_multibyte_characters));
247 setup_echo_area_for_printing (multibyte_p);
248 insert_char (ch);
249 message_dolog ((char *) str, len, 0, multibyte_p);
255 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
256 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
257 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
258 print_buffer. PRINTCHARFUN t means output to the echo area or to
259 stdout if non-interactive. If neither nil nor t, call Lisp
260 function PRINTCHARFUN for each character printed. MULTIBYTE
261 non-zero means PTR contains multibyte characters.
263 In the case where PRINTCHARFUN is nil, it is safe for PTR to point
264 to data in a Lisp string. Otherwise that is not safe. */
266 static void
267 strout (const char *ptr, ptrdiff_t size, ptrdiff_t size_byte,
268 Lisp_Object printcharfun)
270 if (size < 0)
271 size_byte = size = strlen (ptr);
273 if (NILP (printcharfun))
275 ptrdiff_t incr = size_byte - (print_buffer_size - print_buffer_pos_byte);
276 if (incr > 0)
277 print_buffer = xpalloc (print_buffer, &print_buffer_size, incr, -1, 1);
278 memcpy (print_buffer + print_buffer_pos_byte, ptr, size_byte);
279 print_buffer_pos += size;
280 print_buffer_pos_byte += size_byte;
282 else if (noninteractive && EQ (printcharfun, Qt))
284 fwrite (ptr, 1, size_byte, stdout);
285 noninteractive_need_newline = 1;
287 else if (EQ (printcharfun, Qt))
289 /* Output to echo area. We're trying to avoid a little overhead
290 here, that's the reason we don't call printchar to do the
291 job. */
292 int i;
293 bool multibyte_p
294 = !NILP (BVAR (current_buffer, enable_multibyte_characters));
296 setup_echo_area_for_printing (multibyte_p);
297 message_dolog (ptr, size_byte, 0, multibyte_p);
299 if (size == size_byte)
301 for (i = 0; i < size; ++i)
302 insert_char ((unsigned char) *ptr++);
304 else
306 int len;
307 for (i = 0; i < size_byte; i += len)
309 int ch = STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr + i,
310 len);
311 insert_char (ch);
315 else
317 /* PRINTCHARFUN is a Lisp function. */
318 ptrdiff_t i = 0;
320 if (size == size_byte)
322 while (i < size_byte)
324 int ch = ptr[i++];
325 PRINTCHAR (ch);
328 else
330 while (i < size_byte)
332 /* Here, we must convert each multi-byte form to the
333 corresponding character code before handing it to
334 PRINTCHAR. */
335 int len;
336 int ch = STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr + i,
337 len);
338 PRINTCHAR (ch);
339 i += len;
345 /* Print the contents of a string STRING using PRINTCHARFUN.
346 It isn't safe to use strout in many cases,
347 because printing one char can relocate. */
349 static void
350 print_string (Lisp_Object string, Lisp_Object printcharfun)
352 if (EQ (printcharfun, Qt) || NILP (printcharfun))
354 ptrdiff_t chars;
356 if (print_escape_nonascii)
357 string = string_escape_byte8 (string);
359 if (STRING_MULTIBYTE (string))
360 chars = SCHARS (string);
361 else if (! print_escape_nonascii
362 && (EQ (printcharfun, Qt)
363 ? ! NILP (BVAR (&buffer_defaults, enable_multibyte_characters))
364 : ! NILP (BVAR (current_buffer, enable_multibyte_characters))))
366 /* If unibyte string STRING contains 8-bit codes, we must
367 convert STRING to a multibyte string containing the same
368 character codes. */
369 Lisp_Object newstr;
370 ptrdiff_t bytes;
372 chars = SBYTES (string);
373 bytes = count_size_as_multibyte (SDATA (string), chars);
374 if (chars < bytes)
376 newstr = make_uninit_multibyte_string (chars, bytes);
377 memcpy (SDATA (newstr), SDATA (string), chars);
378 str_to_multibyte (SDATA (newstr), bytes, chars);
379 string = newstr;
382 else
383 chars = SBYTES (string);
385 if (EQ (printcharfun, Qt))
387 /* Output to echo area. */
388 ptrdiff_t nbytes = SBYTES (string);
390 /* Copy the string contents so that relocation of STRING by
391 GC does not cause trouble. */
392 USE_SAFE_ALLOCA;
393 char *buffer = SAFE_ALLOCA (nbytes);
394 memcpy (buffer, SDATA (string), nbytes);
396 strout (buffer, chars, nbytes, printcharfun);
398 SAFE_FREE ();
400 else
401 /* No need to copy, since output to print_buffer can't GC. */
402 strout (SSDATA (string), chars, SBYTES (string), printcharfun);
404 else
406 /* Otherwise, string may be relocated by printing one char.
407 So re-fetch the string address for each character. */
408 ptrdiff_t i;
409 ptrdiff_t size = SCHARS (string);
410 ptrdiff_t size_byte = SBYTES (string);
411 struct gcpro gcpro1;
412 GCPRO1 (string);
413 if (size == size_byte)
414 for (i = 0; i < size; i++)
415 PRINTCHAR (SREF (string, i));
416 else
417 for (i = 0; i < size_byte; )
419 /* Here, we must convert each multi-byte form to the
420 corresponding character code before handing it to PRINTCHAR. */
421 int len;
422 int ch = STRING_CHAR_AND_LENGTH (SDATA (string) + i, len);
423 PRINTCHAR (ch);
424 i += len;
426 UNGCPRO;
430 DEFUN ("write-char", Fwrite_char, Swrite_char, 1, 2, 0,
431 doc: /* Output character CHARACTER to stream PRINTCHARFUN.
432 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
433 (Lisp_Object character, Lisp_Object printcharfun)
435 PRINTDECLARE;
437 if (NILP (printcharfun))
438 printcharfun = Vstandard_output;
439 CHECK_NUMBER (character);
440 PRINTPREPARE;
441 PRINTCHAR (XINT (character));
442 PRINTFINISH;
443 return character;
446 /* Used from outside of print.c to print a block of SIZE
447 single-byte chars at DATA on the default output stream.
448 Do not use this on the contents of a Lisp string. */
450 void
451 write_string (const char *data, int size)
453 PRINTDECLARE;
454 Lisp_Object printcharfun;
456 printcharfun = Vstandard_output;
458 PRINTPREPARE;
459 strout (data, size, size, printcharfun);
460 PRINTFINISH;
463 /* Used to print a block of SIZE single-byte chars at DATA on a
464 specified stream PRINTCHARFUN.
465 Do not use this on the contents of a Lisp string. */
467 static void
468 write_string_1 (const char *data, int size, Lisp_Object printcharfun)
470 PRINTDECLARE;
472 PRINTPREPARE;
473 strout (data, size, size, printcharfun);
474 PRINTFINISH;
478 void
479 temp_output_buffer_setup (const char *bufname)
481 ptrdiff_t count = SPECPDL_INDEX ();
482 register struct buffer *old = current_buffer;
483 register Lisp_Object buf;
485 record_unwind_current_buffer ();
487 Fset_buffer (Fget_buffer_create (build_string (bufname)));
489 Fkill_all_local_variables ();
490 delete_all_overlays (current_buffer);
491 bset_directory (current_buffer, BVAR (old, directory));
492 bset_read_only (current_buffer, Qnil);
493 bset_filename (current_buffer, Qnil);
494 bset_undo_list (current_buffer, Qt);
495 eassert (current_buffer->overlays_before == NULL);
496 eassert (current_buffer->overlays_after == NULL);
497 bset_enable_multibyte_characters
498 (current_buffer, BVAR (&buffer_defaults, enable_multibyte_characters));
499 specbind (Qinhibit_read_only, Qt);
500 specbind (Qinhibit_modification_hooks, Qt);
501 Ferase_buffer ();
502 XSETBUFFER (buf, current_buffer);
504 Frun_hooks (1, &Qtemp_buffer_setup_hook);
506 unbind_to (count, Qnil);
508 specbind (Qstandard_output, buf);
511 static void print (Lisp_Object, Lisp_Object, bool);
512 static void print_preprocess (Lisp_Object);
513 static void print_preprocess_string (INTERVAL, Lisp_Object);
514 static void print_object (Lisp_Object, Lisp_Object, bool);
516 DEFUN ("terpri", Fterpri, Sterpri, 0, 1, 0,
517 doc: /* Output a newline to stream PRINTCHARFUN.
518 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
519 (Lisp_Object printcharfun)
521 PRINTDECLARE;
523 if (NILP (printcharfun))
524 printcharfun = Vstandard_output;
525 PRINTPREPARE;
526 PRINTCHAR ('\n');
527 PRINTFINISH;
528 return Qt;
531 DEFUN ("prin1", Fprin1, Sprin1, 1, 2, 0,
532 doc: /* Output the printed representation of OBJECT, any Lisp object.
533 Quoting characters are printed when needed to make output that `read'
534 can handle, whenever this is possible. For complex objects, the behavior
535 is controlled by `print-level' and `print-length', which see.
537 OBJECT is any of the Lisp data types: a number, a string, a symbol,
538 a list, a buffer, a window, a frame, etc.
540 A printed representation of an object is text which describes that object.
542 Optional argument PRINTCHARFUN is the output stream, which can be one
543 of these:
545 - a buffer, in which case output is inserted into that buffer at point;
546 - a marker, in which case output is inserted at marker's position;
547 - a function, in which case that function is called once for each
548 character of OBJECT's printed representation;
549 - a symbol, in which case that symbol's function definition is called; or
550 - t, in which case the output is displayed in the echo area.
552 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
553 is used instead. */)
554 (Lisp_Object object, Lisp_Object printcharfun)
556 PRINTDECLARE;
558 if (NILP (printcharfun))
559 printcharfun = Vstandard_output;
560 PRINTPREPARE;
561 print (object, printcharfun, 1);
562 PRINTFINISH;
563 return object;
566 /* a buffer which is used to hold output being built by prin1-to-string */
567 Lisp_Object Vprin1_to_string_buffer;
569 DEFUN ("prin1-to-string", Fprin1_to_string, Sprin1_to_string, 1, 2, 0,
570 doc: /* Return a string containing the printed representation of OBJECT.
571 OBJECT can be any Lisp object. This function outputs quoting characters
572 when necessary to make output that `read' can handle, whenever possible,
573 unless the optional second argument NOESCAPE is non-nil. For complex objects,
574 the behavior is controlled by `print-level' and `print-length', which see.
576 OBJECT is any of the Lisp data types: a number, a string, a symbol,
577 a list, a buffer, a window, a frame, etc.
579 A printed representation of an object is text which describes that object. */)
580 (Lisp_Object object, Lisp_Object noescape)
582 Lisp_Object printcharfun;
583 bool prev_abort_on_gc;
584 /* struct gcpro gcpro1, gcpro2; */
585 Lisp_Object save_deactivate_mark;
586 ptrdiff_t count = SPECPDL_INDEX ();
587 struct buffer *previous;
589 specbind (Qinhibit_modification_hooks, Qt);
592 PRINTDECLARE;
594 /* Save and restore this--we are altering a buffer
595 but we don't want to deactivate the mark just for that.
596 No need for specbind, since errors deactivate the mark. */
597 save_deactivate_mark = Vdeactivate_mark;
598 /* GCPRO2 (object, save_deactivate_mark); */
599 prev_abort_on_gc = abort_on_gc;
600 abort_on_gc = 1;
602 printcharfun = Vprin1_to_string_buffer;
603 PRINTPREPARE;
604 print (object, printcharfun, NILP (noescape));
605 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINISH */
606 PRINTFINISH;
609 previous = current_buffer;
610 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
611 object = Fbuffer_string ();
612 if (SBYTES (object) == SCHARS (object))
613 STRING_SET_UNIBYTE (object);
615 /* Note that this won't make prepare_to_modify_buffer call
616 ask-user-about-supersession-threat because this buffer
617 does not visit a file. */
618 Ferase_buffer ();
619 set_buffer_internal (previous);
621 Vdeactivate_mark = save_deactivate_mark;
622 /* UNGCPRO; */
624 abort_on_gc = prev_abort_on_gc;
625 return unbind_to (count, object);
628 DEFUN ("princ", Fprinc, Sprinc, 1, 2, 0,
629 doc: /* Output the printed representation of OBJECT, any Lisp object.
630 No quoting characters are used; no delimiters are printed around
631 the contents of strings.
633 OBJECT is any of the Lisp data types: a number, a string, a symbol,
634 a list, a buffer, a window, a frame, etc.
636 A printed representation of an object is text which describes that object.
638 Optional argument PRINTCHARFUN is the output stream, which can be one
639 of these:
641 - a buffer, in which case output is inserted into that buffer at point;
642 - a marker, in which case output is inserted at marker's position;
643 - a function, in which case that function is called once for each
644 character of OBJECT's printed representation;
645 - a symbol, in which case that symbol's function definition is called; or
646 - t, in which case the output is displayed in the echo area.
648 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
649 is used instead. */)
650 (Lisp_Object object, Lisp_Object printcharfun)
652 PRINTDECLARE;
654 if (NILP (printcharfun))
655 printcharfun = Vstandard_output;
656 PRINTPREPARE;
657 print (object, printcharfun, 0);
658 PRINTFINISH;
659 return object;
662 DEFUN ("print", Fprint, Sprint, 1, 2, 0,
663 doc: /* Output the printed representation of OBJECT, with newlines around it.
664 Quoting characters are printed when needed to make output that `read'
665 can handle, whenever this is possible. For complex objects, the behavior
666 is controlled by `print-level' and `print-length', which see.
668 OBJECT is any of the Lisp data types: a number, a string, a symbol,
669 a list, a buffer, a window, a frame, etc.
671 A printed representation of an object is text which describes that object.
673 Optional argument PRINTCHARFUN is the output stream, which can be one
674 of these:
676 - a buffer, in which case output is inserted into that buffer at point;
677 - a marker, in which case output is inserted at marker's position;
678 - a function, in which case that function is called once for each
679 character of OBJECT's printed representation;
680 - a symbol, in which case that symbol's function definition is called; or
681 - t, in which case the output is displayed in the echo area.
683 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
684 is used instead. */)
685 (Lisp_Object object, Lisp_Object printcharfun)
687 PRINTDECLARE;
688 struct gcpro gcpro1;
690 if (NILP (printcharfun))
691 printcharfun = Vstandard_output;
692 GCPRO1 (object);
693 PRINTPREPARE;
694 PRINTCHAR ('\n');
695 print (object, printcharfun, 1);
696 PRINTCHAR ('\n');
697 PRINTFINISH;
698 UNGCPRO;
699 return object;
702 /* The subroutine object for external-debugging-output is kept here
703 for the convenience of the debugger. */
704 Lisp_Object Qexternal_debugging_output;
706 DEFUN ("external-debugging-output", Fexternal_debugging_output, Sexternal_debugging_output, 1, 1, 0,
707 doc: /* Write CHARACTER to stderr.
708 You can call print while debugging emacs, and pass it this function
709 to make it write to the debugging output. */)
710 (Lisp_Object character)
712 unsigned int ch;
714 CHECK_NUMBER (character);
715 ch = XINT (character);
716 if (ASCII_CHAR_P (ch))
718 putc (ch, stderr);
719 #ifdef WINDOWSNT
720 /* Send the output to a debugger (nothing happens if there isn't
721 one). */
722 if (print_output_debug_flag)
724 char buf[2] = {(char) XINT (character), '\0'};
725 OutputDebugString (buf);
727 #endif
729 else
731 unsigned char mbstr[MAX_MULTIBYTE_LENGTH];
732 ptrdiff_t len = CHAR_STRING (ch, mbstr);
733 Lisp_Object encoded_ch =
734 ENCODE_SYSTEM (make_multibyte_string ((char *) mbstr, 1, len));
736 fwrite (SSDATA (encoded_ch), SBYTES (encoded_ch), 1, stderr);
737 #ifdef WINDOWSNT
738 if (print_output_debug_flag)
739 OutputDebugString (SSDATA (encoded_ch));
740 #endif
743 return character;
746 /* This function is never called. Its purpose is to prevent
747 print_output_debug_flag from being optimized away. */
749 extern void debug_output_compilation_hack (bool) EXTERNALLY_VISIBLE;
750 void
751 debug_output_compilation_hack (bool x)
753 print_output_debug_flag = x;
756 #if defined (GNU_LINUX)
758 /* This functionality is not vitally important in general, so we rely on
759 non-portable ability to use stderr as lvalue. */
761 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
763 static FILE *initial_stderr_stream = NULL;
765 DEFUN ("redirect-debugging-output", Fredirect_debugging_output, Sredirect_debugging_output,
766 1, 2,
767 "FDebug output file: \nP",
768 doc: /* Redirect debugging output (stderr stream) to file FILE.
769 If FILE is nil, reset target to the initial stderr stream.
770 Optional arg APPEND non-nil (interactively, with prefix arg) means
771 append to existing target file. */)
772 (Lisp_Object file, Lisp_Object append)
774 if (initial_stderr_stream != NULL)
776 block_input ();
777 fclose (stderr);
778 unblock_input ();
780 stderr = initial_stderr_stream;
781 initial_stderr_stream = NULL;
783 if (STRINGP (file))
785 file = Fexpand_file_name (file, Qnil);
786 initial_stderr_stream = stderr;
787 stderr = emacs_fopen (SSDATA (file), NILP (append) ? "w" : "a");
788 if (stderr == NULL)
790 stderr = initial_stderr_stream;
791 initial_stderr_stream = NULL;
792 report_file_error ("Cannot open debugging output stream", file);
795 return Qnil;
797 #endif /* GNU_LINUX */
800 /* This is the interface for debugging printing. */
802 void
803 debug_print (Lisp_Object arg)
805 Fprin1 (arg, Qexternal_debugging_output);
806 fprintf (stderr, "\r\n");
809 void safe_debug_print (Lisp_Object) EXTERNALLY_VISIBLE;
810 void
811 safe_debug_print (Lisp_Object arg)
813 int valid = valid_lisp_object_p (arg);
815 if (valid > 0)
816 debug_print (arg);
817 else
818 fprintf (stderr, "#<%s_LISP_OBJECT 0x%08"pI"x>\r\n",
819 !valid ? "INVALID" : "SOME",
820 XLI (arg));
824 DEFUN ("error-message-string", Ferror_message_string, Serror_message_string,
825 1, 1, 0,
826 doc: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
827 See Info anchor `(elisp)Definition of signal' for some details on how this
828 error message is constructed. */)
829 (Lisp_Object obj)
831 struct buffer *old = current_buffer;
832 Lisp_Object value;
833 struct gcpro gcpro1;
835 /* If OBJ is (error STRING), just return STRING.
836 That is not only faster, it also avoids the need to allocate
837 space here when the error is due to memory full. */
838 if (CONSP (obj) && EQ (XCAR (obj), Qerror)
839 && CONSP (XCDR (obj))
840 && STRINGP (XCAR (XCDR (obj)))
841 && NILP (XCDR (XCDR (obj))))
842 return XCAR (XCDR (obj));
844 print_error_message (obj, Vprin1_to_string_buffer, 0, Qnil);
846 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
847 value = Fbuffer_string ();
849 GCPRO1 (value);
850 Ferase_buffer ();
851 set_buffer_internal (old);
852 UNGCPRO;
854 return value;
857 /* Print an error message for the error DATA onto Lisp output stream
858 STREAM (suitable for the print functions).
859 CONTEXT is a C string describing the context of the error.
860 CALLER is the Lisp function inside which the error was signaled. */
862 void
863 print_error_message (Lisp_Object data, Lisp_Object stream, const char *context,
864 Lisp_Object caller)
866 Lisp_Object errname, errmsg, file_error, tail;
867 struct gcpro gcpro1;
869 if (context != 0)
870 write_string_1 (context, -1, stream);
872 /* If we know from where the error was signaled, show it in
873 *Messages*. */
874 if (!NILP (caller) && SYMBOLP (caller))
876 Lisp_Object cname = SYMBOL_NAME (caller);
877 ptrdiff_t cnamelen = SBYTES (cname);
878 USE_SAFE_ALLOCA;
879 char *name = SAFE_ALLOCA (cnamelen);
880 memcpy (name, SDATA (cname), cnamelen);
881 message_dolog (name, cnamelen, 0, 0);
882 message_dolog (": ", 2, 0, 0);
883 SAFE_FREE ();
886 errname = Fcar (data);
888 if (EQ (errname, Qerror))
890 data = Fcdr (data);
891 if (!CONSP (data))
892 data = Qnil;
893 errmsg = Fcar (data);
894 file_error = Qnil;
896 else
898 Lisp_Object error_conditions = Fget (errname, Qerror_conditions);
899 errmsg = Fget (errname, Qerror_message);
900 file_error = Fmemq (Qfile_error, error_conditions);
903 /* Print an error message including the data items. */
905 tail = Fcdr_safe (data);
906 GCPRO1 (tail);
908 /* For file-error, make error message by concatenating
909 all the data items. They are all strings. */
910 if (!NILP (file_error) && CONSP (tail))
911 errmsg = XCAR (tail), tail = XCDR (tail);
914 const char *sep = ": ";
916 if (!STRINGP (errmsg))
917 write_string_1 ("peculiar error", -1, stream);
918 else if (SCHARS (errmsg))
919 Fprinc (errmsg, stream);
920 else
921 sep = NULL;
923 for (; CONSP (tail); tail = XCDR (tail), sep = ", ")
925 Lisp_Object obj;
927 if (sep)
928 write_string_1 (sep, 2, stream);
929 obj = XCAR (tail);
930 if (!NILP (file_error)
931 || EQ (errname, Qend_of_file) || EQ (errname, Quser_error))
932 Fprinc (obj, stream);
933 else
934 Fprin1 (obj, stream);
938 UNGCPRO;
944 * The buffer should be at least as large as the max string size of the
945 * largest float, printed in the biggest notation. This is undoubtedly
946 * 20d float_output_format, with the negative of the C-constant "HUGE"
947 * from <math.h>.
949 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
951 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
952 * case of -1e307 in 20d float_output_format. What is one to do (short of
953 * re-writing _doprnt to be more sane)?
954 * -wsr
955 * Given the above, the buffer must be least FLOAT_TO_STRING_BUFSIZE bytes.
959 float_to_string (char *buf, double data)
961 char *cp;
962 int width;
963 int len;
965 /* Check for plus infinity in a way that won't lose
966 if there is no plus infinity. */
967 if (data == data / 2 && data > 1.0)
969 static char const infinity_string[] = "1.0e+INF";
970 strcpy (buf, infinity_string);
971 return sizeof infinity_string - 1;
973 /* Likewise for minus infinity. */
974 if (data == data / 2 && data < -1.0)
976 static char const minus_infinity_string[] = "-1.0e+INF";
977 strcpy (buf, minus_infinity_string);
978 return sizeof minus_infinity_string - 1;
980 /* Check for NaN in a way that won't fail if there are no NaNs. */
981 if (! (data * 0.0 >= 0.0))
983 /* Prepend "-" if the NaN's sign bit is negative.
984 The sign bit of a double is the bit that is 1 in -0.0. */
985 static char const NaN_string[] = "0.0e+NaN";
986 int i;
987 union { double d; char c[sizeof (double)]; } u_data, u_minus_zero;
988 bool negative = 0;
989 u_data.d = data;
990 u_minus_zero.d = - 0.0;
991 for (i = 0; i < sizeof (double); i++)
992 if (u_data.c[i] & u_minus_zero.c[i])
994 *buf = '-';
995 negative = 1;
996 break;
999 strcpy (buf + negative, NaN_string);
1000 return negative + sizeof NaN_string - 1;
1003 if (NILP (Vfloat_output_format)
1004 || !STRINGP (Vfloat_output_format))
1005 lose:
1007 /* Generate the fewest number of digits that represent the
1008 floating point value without losing information. */
1009 len = dtoastr (buf, FLOAT_TO_STRING_BUFSIZE - 2, 0, 0, data);
1010 /* The decimal point must be printed, or the byte compiler can
1011 get confused (Bug#8033). */
1012 width = 1;
1014 else /* oink oink */
1016 /* Check that the spec we have is fully valid.
1017 This means not only valid for printf,
1018 but meant for floats, and reasonable. */
1019 cp = SSDATA (Vfloat_output_format);
1021 if (cp[0] != '%')
1022 goto lose;
1023 if (cp[1] != '.')
1024 goto lose;
1026 cp += 2;
1028 /* Check the width specification. */
1029 width = -1;
1030 if ('0' <= *cp && *cp <= '9')
1032 width = 0;
1035 width = (width * 10) + (*cp++ - '0');
1036 if (DBL_DIG < width)
1037 goto lose;
1039 while (*cp >= '0' && *cp <= '9');
1041 /* A precision of zero is valid only for %f. */
1042 if (width == 0 && *cp != 'f')
1043 goto lose;
1046 if (*cp != 'e' && *cp != 'f' && *cp != 'g')
1047 goto lose;
1049 if (cp[1] != 0)
1050 goto lose;
1052 len = sprintf (buf, SSDATA (Vfloat_output_format), data);
1055 /* Make sure there is a decimal point with digit after, or an
1056 exponent, so that the value is readable as a float. But don't do
1057 this with "%.0f"; it's valid for that not to produce a decimal
1058 point. Note that width can be 0 only for %.0f. */
1059 if (width != 0)
1061 for (cp = buf; *cp; cp++)
1062 if ((*cp < '0' || *cp > '9') && *cp != '-')
1063 break;
1065 if (*cp == '.' && cp[1] == 0)
1067 cp[1] = '0';
1068 cp[2] = 0;
1069 len++;
1071 else if (*cp == 0)
1073 *cp++ = '.';
1074 *cp++ = '0';
1075 *cp++ = 0;
1076 len += 2;
1080 return len;
1084 static void
1085 print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
1087 new_backquote_output = 0;
1089 /* Reset print_number_index and Vprint_number_table only when
1090 the variable Vprint_continuous_numbering is nil. Otherwise,
1091 the values of these variables will be kept between several
1092 print functions. */
1093 if (NILP (Vprint_continuous_numbering)
1094 || NILP (Vprint_number_table))
1096 print_number_index = 0;
1097 Vprint_number_table = Qnil;
1100 /* Construct Vprint_number_table for print-gensym and print-circle. */
1101 if (!NILP (Vprint_gensym) || !NILP (Vprint_circle))
1103 /* Construct Vprint_number_table.
1104 This increments print_number_index for the objects added. */
1105 print_depth = 0;
1106 print_preprocess (obj);
1108 if (HASH_TABLE_P (Vprint_number_table))
1109 { /* Remove unnecessary objects, which appear only once in OBJ;
1110 that is, whose status is Qt. */
1111 struct Lisp_Hash_Table *h = XHASH_TABLE (Vprint_number_table);
1112 ptrdiff_t i;
1114 for (i = 0; i < HASH_TABLE_SIZE (h); ++i)
1115 if (!NILP (HASH_HASH (h, i))
1116 && EQ (HASH_VALUE (h, i), Qt))
1117 Fremhash (HASH_KEY (h, i), Vprint_number_table);
1121 print_depth = 0;
1122 print_object (obj, printcharfun, escapeflag);
1125 #define PRINT_CIRCLE_CANDIDATE_P(obj) \
1126 (STRINGP (obj) || CONSP (obj) \
1127 || (VECTORLIKEP (obj) \
1128 && (VECTORP (obj) || COMPILEDP (obj) \
1129 || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \
1130 || HASH_TABLE_P (obj) || FONTP (obj))) \
1131 || (! NILP (Vprint_gensym) \
1132 && SYMBOLP (obj) \
1133 && !SYMBOL_INTERNED_P (obj)))
1135 /* Construct Vprint_number_table according to the structure of OBJ.
1136 OBJ itself and all its elements will be added to Vprint_number_table
1137 recursively if it is a list, vector, compiled function, char-table,
1138 string (its text properties will be traced), or a symbol that has
1139 no obarray (this is for the print-gensym feature).
1140 The status fields of Vprint_number_table mean whether each object appears
1141 more than once in OBJ: Qnil at the first time, and Qt after that. */
1142 static void
1143 print_preprocess (Lisp_Object obj)
1145 int i;
1146 ptrdiff_t size;
1147 int loop_count = 0;
1148 Lisp_Object halftail;
1150 /* Avoid infinite recursion for circular nested structure
1151 in the case where Vprint_circle is nil. */
1152 if (NILP (Vprint_circle))
1154 /* Give up if we go so deep that print_object will get an error. */
1155 /* See similar code in print_object. */
1156 if (print_depth >= PRINT_CIRCLE)
1157 error ("Apparently circular structure being printed");
1159 for (i = 0; i < print_depth; i++)
1160 if (EQ (obj, being_printed[i]))
1161 return;
1162 being_printed[print_depth] = obj;
1165 print_depth++;
1166 halftail = obj;
1168 loop:
1169 if (PRINT_CIRCLE_CANDIDATE_P (obj))
1171 if (!HASH_TABLE_P (Vprint_number_table))
1173 Lisp_Object args[2];
1174 args[0] = QCtest;
1175 args[1] = Qeq;
1176 Vprint_number_table = Fmake_hash_table (2, args);
1179 /* In case print-circle is nil and print-gensym is t,
1180 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1181 if (! NILP (Vprint_circle) || SYMBOLP (obj))
1183 Lisp_Object num = Fgethash (obj, Vprint_number_table, Qnil);
1184 if (!NILP (num)
1185 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1186 always print the gensym with a number. This is a special for
1187 the lisp function byte-compile-output-docform. */
1188 || (!NILP (Vprint_continuous_numbering)
1189 && SYMBOLP (obj)
1190 && !SYMBOL_INTERNED_P (obj)))
1191 { /* OBJ appears more than once. Let's remember that. */
1192 if (!INTEGERP (num))
1194 print_number_index++;
1195 /* Negative number indicates it hasn't been printed yet. */
1196 Fputhash (obj, make_number (- print_number_index),
1197 Vprint_number_table);
1199 print_depth--;
1200 return;
1202 else
1203 /* OBJ is not yet recorded. Let's add to the table. */
1204 Fputhash (obj, Qt, Vprint_number_table);
1207 switch (XTYPE (obj))
1209 case Lisp_String:
1210 /* A string may have text properties, which can be circular. */
1211 traverse_intervals_noorder (string_intervals (obj),
1212 print_preprocess_string, Qnil);
1213 break;
1215 case Lisp_Cons:
1216 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1217 just as in print_object. */
1218 if (loop_count && EQ (obj, halftail))
1219 break;
1220 print_preprocess (XCAR (obj));
1221 obj = XCDR (obj);
1222 loop_count++;
1223 if (!(loop_count & 1))
1224 halftail = XCDR (halftail);
1225 goto loop;
1227 case Lisp_Vectorlike:
1228 size = ASIZE (obj);
1229 if (size & PSEUDOVECTOR_FLAG)
1230 size &= PSEUDOVECTOR_SIZE_MASK;
1231 for (i = 0; i < size; i++)
1232 print_preprocess (AREF (obj, i));
1233 if (HASH_TABLE_P (obj))
1234 { /* For hash tables, the key_and_value slot is past
1235 `size' because it needs to be marked specially in case
1236 the table is weak. */
1237 struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
1238 print_preprocess (h->key_and_value);
1240 break;
1242 default:
1243 break;
1246 print_depth--;
1249 static void
1250 print_preprocess_string (INTERVAL interval, Lisp_Object arg)
1252 print_preprocess (interval->plist);
1255 static void print_check_string_charset_prop (INTERVAL interval, Lisp_Object string);
1257 #define PRINT_STRING_NON_CHARSET_FOUND 1
1258 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1260 /* Bitwise or of the above macros. */
1261 static int print_check_string_result;
1263 static void
1264 print_check_string_charset_prop (INTERVAL interval, Lisp_Object string)
1266 Lisp_Object val;
1268 if (NILP (interval->plist)
1269 || (print_check_string_result == (PRINT_STRING_NON_CHARSET_FOUND
1270 | PRINT_STRING_UNSAFE_CHARSET_FOUND)))
1271 return;
1272 for (val = interval->plist; CONSP (val) && ! EQ (XCAR (val), Qcharset);
1273 val = XCDR (XCDR (val)));
1274 if (! CONSP (val))
1276 print_check_string_result |= PRINT_STRING_NON_CHARSET_FOUND;
1277 return;
1279 if (! (print_check_string_result & PRINT_STRING_NON_CHARSET_FOUND))
1281 if (! EQ (val, interval->plist)
1282 || CONSP (XCDR (XCDR (val))))
1283 print_check_string_result |= PRINT_STRING_NON_CHARSET_FOUND;
1285 if (NILP (Vprint_charset_text_property)
1286 || ! (print_check_string_result & PRINT_STRING_UNSAFE_CHARSET_FOUND))
1288 int i, c;
1289 ptrdiff_t charpos = interval->position;
1290 ptrdiff_t bytepos = string_char_to_byte (string, charpos);
1291 Lisp_Object charset;
1293 charset = XCAR (XCDR (val));
1294 for (i = 0; i < LENGTH (interval); i++)
1296 FETCH_STRING_CHAR_ADVANCE (c, string, charpos, bytepos);
1297 if (! ASCII_CHAR_P (c)
1298 && ! EQ (CHARSET_NAME (CHAR_CHARSET (c)), charset))
1300 print_check_string_result |= PRINT_STRING_UNSAFE_CHARSET_FOUND;
1301 break;
1307 /* The value is (charset . nil). */
1308 static Lisp_Object print_prune_charset_plist;
1310 static Lisp_Object
1311 print_prune_string_charset (Lisp_Object string)
1313 print_check_string_result = 0;
1314 traverse_intervals (string_intervals (string), 0,
1315 print_check_string_charset_prop, string);
1316 if (! (print_check_string_result & PRINT_STRING_UNSAFE_CHARSET_FOUND))
1318 string = Fcopy_sequence (string);
1319 if (print_check_string_result & PRINT_STRING_NON_CHARSET_FOUND)
1321 if (NILP (print_prune_charset_plist))
1322 print_prune_charset_plist = list1 (Qcharset);
1323 Fremove_text_properties (make_number (0),
1324 make_number (SCHARS (string)),
1325 print_prune_charset_plist, string);
1327 else
1328 Fset_text_properties (make_number (0), make_number (SCHARS (string)),
1329 Qnil, string);
1331 return string;
1334 static void
1335 print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
1337 char buf[max (sizeof "from..to..in " + 2 * INT_STRLEN_BOUND (EMACS_INT),
1338 max (sizeof " . #" + INT_STRLEN_BOUND (printmax_t),
1339 40))];
1341 QUIT;
1343 /* Detect circularities and truncate them. */
1344 if (NILP (Vprint_circle))
1346 /* Simple but incomplete way. */
1347 int i;
1349 /* See similar code in print_preprocess. */
1350 if (print_depth >= PRINT_CIRCLE)
1351 error ("Apparently circular structure being printed");
1353 for (i = 0; i < print_depth; i++)
1354 if (EQ (obj, being_printed[i]))
1356 int len = sprintf (buf, "#%d", i);
1357 strout (buf, len, len, printcharfun);
1358 return;
1360 being_printed[print_depth] = obj;
1362 else if (PRINT_CIRCLE_CANDIDATE_P (obj))
1364 /* With the print-circle feature. */
1365 Lisp_Object num = Fgethash (obj, Vprint_number_table, Qnil);
1366 if (INTEGERP (num))
1368 EMACS_INT n = XINT (num);
1369 if (n < 0)
1370 { /* Add a prefix #n= if OBJ has not yet been printed;
1371 that is, its status field is nil. */
1372 int len = sprintf (buf, "#%"pI"d=", -n);
1373 strout (buf, len, len, printcharfun);
1374 /* OBJ is going to be printed. Remember that fact. */
1375 Fputhash (obj, make_number (- n), Vprint_number_table);
1377 else
1379 /* Just print #n# if OBJ has already been printed. */
1380 int len = sprintf (buf, "#%"pI"d#", n);
1381 strout (buf, len, len, printcharfun);
1382 return;
1387 print_depth++;
1389 switch (XTYPE (obj))
1391 case_Lisp_Int:
1393 int len = sprintf (buf, "%"pI"d", XINT (obj));
1394 strout (buf, len, len, printcharfun);
1396 break;
1398 case Lisp_Float:
1400 char pigbuf[FLOAT_TO_STRING_BUFSIZE];
1401 int len = float_to_string (pigbuf, XFLOAT_DATA (obj));
1402 strout (pigbuf, len, len, printcharfun);
1404 break;
1406 case Lisp_String:
1407 if (!escapeflag)
1408 print_string (obj, printcharfun);
1409 else
1411 register ptrdiff_t i, i_byte;
1412 struct gcpro gcpro1;
1413 ptrdiff_t size_byte;
1414 /* 1 means we must ensure that the next character we output
1415 cannot be taken as part of a hex character escape. */
1416 bool need_nonhex = 0;
1417 bool multibyte = STRING_MULTIBYTE (obj);
1419 GCPRO1 (obj);
1421 if (! EQ (Vprint_charset_text_property, Qt))
1422 obj = print_prune_string_charset (obj);
1424 if (string_intervals (obj))
1426 PRINTCHAR ('#');
1427 PRINTCHAR ('(');
1430 PRINTCHAR ('\"');
1431 size_byte = SBYTES (obj);
1433 for (i = 0, i_byte = 0; i_byte < size_byte;)
1435 /* Here, we must convert each multi-byte form to the
1436 corresponding character code before handing it to PRINTCHAR. */
1437 int c;
1439 FETCH_STRING_CHAR_ADVANCE (c, obj, i, i_byte);
1441 QUIT;
1443 if (c == '\n' && print_escape_newlines)
1445 PRINTCHAR ('\\');
1446 PRINTCHAR ('n');
1448 else if (c == '\f' && print_escape_newlines)
1450 PRINTCHAR ('\\');
1451 PRINTCHAR ('f');
1453 else if (multibyte
1454 && (CHAR_BYTE8_P (c)
1455 || (! ASCII_CHAR_P (c) && print_escape_multibyte)))
1457 /* When multibyte is disabled,
1458 print multibyte string chars using hex escapes.
1459 For a char code that could be in a unibyte string,
1460 when found in a multibyte string, always use a hex escape
1461 so it reads back as multibyte. */
1462 char outbuf[50];
1463 int len;
1465 if (CHAR_BYTE8_P (c))
1466 len = sprintf (outbuf, "\\%03o", CHAR_TO_BYTE8 (c));
1467 else
1469 len = sprintf (outbuf, "\\x%04x", c);
1470 need_nonhex = 1;
1472 strout (outbuf, len, len, printcharfun);
1474 else if (! multibyte
1475 && SINGLE_BYTE_CHAR_P (c) && ! ASCII_BYTE_P (c)
1476 && print_escape_nonascii)
1478 /* When printing in a multibyte buffer
1479 or when explicitly requested,
1480 print single-byte non-ASCII string chars
1481 using octal escapes. */
1482 char outbuf[5];
1483 int len = sprintf (outbuf, "\\%03o", c);
1484 strout (outbuf, len, len, printcharfun);
1486 else
1488 /* If we just had a hex escape, and this character
1489 could be taken as part of it,
1490 output `\ ' to prevent that. */
1491 if (need_nonhex)
1493 need_nonhex = 0;
1494 if ((c >= 'a' && c <= 'f')
1495 || (c >= 'A' && c <= 'F')
1496 || (c >= '0' && c <= '9'))
1497 strout ("\\ ", -1, -1, printcharfun);
1500 if (c == '\"' || c == '\\')
1501 PRINTCHAR ('\\');
1502 PRINTCHAR (c);
1505 PRINTCHAR ('\"');
1507 if (string_intervals (obj))
1509 traverse_intervals (string_intervals (obj),
1510 0, print_interval, printcharfun);
1511 PRINTCHAR (')');
1514 UNGCPRO;
1516 break;
1518 case Lisp_Symbol:
1520 bool confusing;
1521 unsigned char *p = SDATA (SYMBOL_NAME (obj));
1522 unsigned char *end = p + SBYTES (SYMBOL_NAME (obj));
1523 int c;
1524 ptrdiff_t i, i_byte;
1525 ptrdiff_t size_byte;
1526 Lisp_Object name;
1528 name = SYMBOL_NAME (obj);
1530 if (p != end && (*p == '-' || *p == '+')) p++;
1531 if (p == end)
1532 confusing = 0;
1533 /* If symbol name begins with a digit, and ends with a digit,
1534 and contains nothing but digits and `e', it could be treated
1535 as a number. So set CONFUSING.
1537 Symbols that contain periods could also be taken as numbers,
1538 but periods are always escaped, so we don't have to worry
1539 about them here. */
1540 else if (*p >= '0' && *p <= '9'
1541 && end[-1] >= '0' && end[-1] <= '9')
1543 while (p != end && ((*p >= '0' && *p <= '9')
1544 /* Needed for \2e10. */
1545 || *p == 'e' || *p == 'E'))
1546 p++;
1547 confusing = (end == p);
1549 else
1550 confusing = 0;
1552 size_byte = SBYTES (name);
1554 if (! NILP (Vprint_gensym) && !SYMBOL_INTERNED_P (obj))
1556 PRINTCHAR ('#');
1557 PRINTCHAR (':');
1559 else if (size_byte == 0)
1561 PRINTCHAR ('#');
1562 PRINTCHAR ('#');
1563 break;
1566 for (i = 0, i_byte = 0; i_byte < size_byte;)
1568 /* Here, we must convert each multi-byte form to the
1569 corresponding character code before handing it to PRINTCHAR. */
1570 FETCH_STRING_CHAR_ADVANCE (c, name, i, i_byte);
1571 QUIT;
1573 if (escapeflag)
1575 if (c == '\"' || c == '\\' || c == '\''
1576 || c == ';' || c == '#' || c == '(' || c == ')'
1577 || c == ',' || c == '.' || c == '`'
1578 || c == '[' || c == ']' || c == '?' || c <= 040
1579 || confusing)
1580 PRINTCHAR ('\\'), confusing = 0;
1582 PRINTCHAR (c);
1585 break;
1587 case Lisp_Cons:
1588 /* If deeper than spec'd depth, print placeholder. */
1589 if (INTEGERP (Vprint_level)
1590 && print_depth > XINT (Vprint_level))
1591 strout ("...", -1, -1, printcharfun);
1592 else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
1593 && (EQ (XCAR (obj), Qquote)))
1595 PRINTCHAR ('\'');
1596 print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
1598 else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
1599 && (EQ (XCAR (obj), Qfunction)))
1601 PRINTCHAR ('#');
1602 PRINTCHAR ('\'');
1603 print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
1605 else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
1606 && ((EQ (XCAR (obj), Qbackquote))))
1608 print_object (XCAR (obj), printcharfun, 0);
1609 new_backquote_output++;
1610 print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
1611 new_backquote_output--;
1613 else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
1614 && new_backquote_output
1615 && ((EQ (XCAR (obj), Qbackquote)
1616 || EQ (XCAR (obj), Qcomma)
1617 || EQ (XCAR (obj), Qcomma_at)
1618 || EQ (XCAR (obj), Qcomma_dot))))
1620 print_object (XCAR (obj), printcharfun, 0);
1621 new_backquote_output--;
1622 print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
1623 new_backquote_output++;
1625 else
1627 PRINTCHAR ('(');
1630 printmax_t i, print_length;
1631 Lisp_Object halftail = obj;
1633 /* Negative values of print-length are invalid in CL.
1634 Treat them like nil, as CMUCL does. */
1635 if (NATNUMP (Vprint_length))
1636 print_length = XFASTINT (Vprint_length);
1637 else
1638 print_length = TYPE_MAXIMUM (printmax_t);
1640 i = 0;
1641 while (CONSP (obj))
1643 /* Detect circular list. */
1644 if (NILP (Vprint_circle))
1646 /* Simple but incomplete way. */
1647 if (i != 0 && EQ (obj, halftail))
1649 int len = sprintf (buf, " . #%"pMd, i / 2);
1650 strout (buf, len, len, printcharfun);
1651 goto end_of_list;
1654 else
1656 /* With the print-circle feature. */
1657 if (i != 0)
1659 Lisp_Object num = Fgethash (obj, Vprint_number_table, Qnil);
1660 if (INTEGERP (num))
1662 strout (" . ", 3, 3, printcharfun);
1663 print_object (obj, printcharfun, escapeflag);
1664 goto end_of_list;
1669 if (i)
1670 PRINTCHAR (' ');
1672 if (print_length <= i)
1674 strout ("...", 3, 3, printcharfun);
1675 goto end_of_list;
1678 i++;
1679 print_object (XCAR (obj), printcharfun, escapeflag);
1681 obj = XCDR (obj);
1682 if (!(i & 1))
1683 halftail = XCDR (halftail);
1687 /* OBJ non-nil here means it's the end of a dotted list. */
1688 if (!NILP (obj))
1690 strout (" . ", 3, 3, printcharfun);
1691 print_object (obj, printcharfun, escapeflag);
1694 end_of_list:
1695 PRINTCHAR (')');
1697 break;
1699 case Lisp_Vectorlike:
1700 if (PROCESSP (obj))
1702 if (escapeflag)
1704 strout ("#<process ", -1, -1, printcharfun);
1705 print_string (XPROCESS (obj)->name, printcharfun);
1706 PRINTCHAR ('>');
1708 else
1709 print_string (XPROCESS (obj)->name, printcharfun);
1711 else if (BOOL_VECTOR_P (obj))
1713 ptrdiff_t i;
1714 int len;
1715 unsigned char c;
1716 struct gcpro gcpro1;
1717 EMACS_INT size = bool_vector_size (obj);
1718 ptrdiff_t size_in_chars = bool_vector_bytes (size);
1719 ptrdiff_t real_size_in_chars = size_in_chars;
1720 GCPRO1 (obj);
1722 PRINTCHAR ('#');
1723 PRINTCHAR ('&');
1724 len = sprintf (buf, "%"pI"d", size);
1725 strout (buf, len, len, printcharfun);
1726 PRINTCHAR ('\"');
1728 /* Don't print more characters than the specified maximum.
1729 Negative values of print-length are invalid. Treat them
1730 like a print-length of nil. */
1731 if (NATNUMP (Vprint_length)
1732 && XFASTINT (Vprint_length) < size_in_chars)
1733 size_in_chars = XFASTINT (Vprint_length);
1735 for (i = 0; i < size_in_chars; i++)
1737 QUIT;
1738 c = bool_vector_uchar_data (obj)[i];
1739 if (c == '\n' && print_escape_newlines)
1741 PRINTCHAR ('\\');
1742 PRINTCHAR ('n');
1744 else if (c == '\f' && print_escape_newlines)
1746 PRINTCHAR ('\\');
1747 PRINTCHAR ('f');
1749 else if (c > '\177')
1751 /* Use octal escapes to avoid encoding issues. */
1752 PRINTCHAR ('\\');
1753 PRINTCHAR ('0' + ((c >> 6) & 3));
1754 PRINTCHAR ('0' + ((c >> 3) & 7));
1755 PRINTCHAR ('0' + (c & 7));
1757 else
1759 if (c == '\"' || c == '\\')
1760 PRINTCHAR ('\\');
1761 PRINTCHAR (c);
1765 if (size_in_chars < real_size_in_chars)
1766 strout (" ...", 4, 4, printcharfun);
1767 PRINTCHAR ('\"');
1769 UNGCPRO;
1771 else if (SUBRP (obj))
1773 strout ("#<subr ", -1, -1, printcharfun);
1774 strout (XSUBR (obj)->symbol_name, -1, -1, printcharfun);
1775 PRINTCHAR ('>');
1777 else if (WINDOWP (obj))
1779 int len;
1780 strout ("#<window ", -1, -1, printcharfun);
1781 len = sprintf (buf, "%d", XWINDOW (obj)->sequence_number);
1782 strout (buf, len, len, printcharfun);
1783 if (BUFFERP (XWINDOW (obj)->contents))
1785 strout (" on ", -1, -1, printcharfun);
1786 print_string (BVAR (XBUFFER (XWINDOW (obj)->contents), name),
1787 printcharfun);
1789 PRINTCHAR ('>');
1791 else if (TERMINALP (obj))
1793 int len;
1794 struct terminal *t = XTERMINAL (obj);
1795 strout ("#<terminal ", -1, -1, printcharfun);
1796 len = sprintf (buf, "%d", t->id);
1797 strout (buf, len, len, printcharfun);
1798 if (t->name)
1800 strout (" on ", -1, -1, printcharfun);
1801 strout (t->name, -1, -1, printcharfun);
1803 PRINTCHAR ('>');
1805 else if (HASH_TABLE_P (obj))
1807 struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
1808 ptrdiff_t i;
1809 ptrdiff_t real_size, size;
1810 int len;
1811 #if 0
1812 void *ptr = h;
1813 strout ("#<hash-table", -1, -1, printcharfun);
1814 if (SYMBOLP (h->test))
1816 PRINTCHAR (' ');
1817 PRINTCHAR ('\'');
1818 strout (SDATA (SYMBOL_NAME (h->test)), -1, -1, printcharfun);
1819 PRINTCHAR (' ');
1820 strout (SDATA (SYMBOL_NAME (h->weak)), -1, -1, printcharfun);
1821 PRINTCHAR (' ');
1822 len = sprintf (buf, "%"pD"d/%"pD"d", h->count, ASIZE (h->next));
1823 strout (buf, len, len, printcharfun);
1825 len = sprintf (buf, " %p>", ptr);
1826 strout (buf, len, len, printcharfun);
1827 #endif
1828 /* Implement a readable output, e.g.:
1829 #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
1830 /* Always print the size. */
1831 len = sprintf (buf, "#s(hash-table size %"pD"d", ASIZE (h->next));
1832 strout (buf, len, len, printcharfun);
1834 if (!NILP (h->test.name))
1836 strout (" test ", -1, -1, printcharfun);
1837 print_object (h->test.name, printcharfun, escapeflag);
1840 if (!NILP (h->weak))
1842 strout (" weakness ", -1, -1, printcharfun);
1843 print_object (h->weak, printcharfun, escapeflag);
1846 if (!NILP (h->rehash_size))
1848 strout (" rehash-size ", -1, -1, printcharfun);
1849 print_object (h->rehash_size, printcharfun, escapeflag);
1852 if (!NILP (h->rehash_threshold))
1854 strout (" rehash-threshold ", -1, -1, printcharfun);
1855 print_object (h->rehash_threshold, printcharfun, escapeflag);
1858 strout (" data ", -1, -1, printcharfun);
1860 /* Print the data here as a plist. */
1861 real_size = HASH_TABLE_SIZE (h);
1862 size = real_size;
1864 /* Don't print more elements than the specified maximum. */
1865 if (NATNUMP (Vprint_length)
1866 && XFASTINT (Vprint_length) < size)
1867 size = XFASTINT (Vprint_length);
1869 PRINTCHAR ('(');
1870 for (i = 0; i < size; i++)
1871 if (!NILP (HASH_HASH (h, i)))
1873 if (i) PRINTCHAR (' ');
1874 print_object (HASH_KEY (h, i), printcharfun, escapeflag);
1875 PRINTCHAR (' ');
1876 print_object (HASH_VALUE (h, i), printcharfun, escapeflag);
1879 if (size < real_size)
1880 strout (" ...", 4, 4, printcharfun);
1882 PRINTCHAR (')');
1883 PRINTCHAR (')');
1886 else if (BUFFERP (obj))
1888 if (!BUFFER_LIVE_P (XBUFFER (obj)))
1889 strout ("#<killed buffer>", -1, -1, printcharfun);
1890 else if (escapeflag)
1892 strout ("#<buffer ", -1, -1, printcharfun);
1893 print_string (BVAR (XBUFFER (obj), name), printcharfun);
1894 PRINTCHAR ('>');
1896 else
1897 print_string (BVAR (XBUFFER (obj), name), printcharfun);
1899 else if (WINDOW_CONFIGURATIONP (obj))
1901 strout ("#<window-configuration>", -1, -1, printcharfun);
1903 else if (FRAMEP (obj))
1905 int len;
1906 void *ptr = XFRAME (obj);
1907 Lisp_Object frame_name = XFRAME (obj)->name;
1909 strout ((FRAME_LIVE_P (XFRAME (obj))
1910 ? "#<frame " : "#<dead frame "),
1911 -1, -1, printcharfun);
1912 if (!STRINGP (frame_name))
1914 /* A frame could be too young and have no name yet;
1915 don't crash. */
1916 if (SYMBOLP (frame_name))
1917 frame_name = Fsymbol_name (frame_name);
1918 else /* can't happen: name should be either nil or string */
1919 frame_name = build_string ("*INVALID*FRAME*NAME*");
1921 print_string (frame_name, printcharfun);
1922 len = sprintf (buf, " %p>", ptr);
1923 strout (buf, len, len, printcharfun);
1925 else if (FONTP (obj))
1927 int i;
1929 if (! FONT_OBJECT_P (obj))
1931 if (FONT_SPEC_P (obj))
1932 strout ("#<font-spec", -1, -1, printcharfun);
1933 else
1934 strout ("#<font-entity", -1, -1, printcharfun);
1935 for (i = 0; i < FONT_SPEC_MAX; i++)
1937 PRINTCHAR (' ');
1938 if (i < FONT_WEIGHT_INDEX || i > FONT_WIDTH_INDEX)
1939 print_object (AREF (obj, i), printcharfun, escapeflag);
1940 else
1941 print_object (font_style_symbolic (obj, i, 0),
1942 printcharfun, escapeflag);
1945 else
1947 strout ("#<font-object ", -1, -1, printcharfun);
1948 print_object (AREF (obj, FONT_NAME_INDEX), printcharfun,
1949 escapeflag);
1951 PRINTCHAR ('>');
1953 else
1955 ptrdiff_t size = ASIZE (obj);
1956 if (COMPILEDP (obj))
1958 PRINTCHAR ('#');
1959 size &= PSEUDOVECTOR_SIZE_MASK;
1961 if (CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj))
1963 /* We print a char-table as if it were a vector,
1964 lumping the parent and default slots in with the
1965 character slots. But we add #^ as a prefix. */
1967 /* Make each lowest sub_char_table start a new line.
1968 Otherwise we'll make a line extremely long, which
1969 results in slow redisplay. */
1970 if (SUB_CHAR_TABLE_P (obj)
1971 && XINT (XSUB_CHAR_TABLE (obj)->depth) == 3)
1972 PRINTCHAR ('\n');
1973 PRINTCHAR ('#');
1974 PRINTCHAR ('^');
1975 if (SUB_CHAR_TABLE_P (obj))
1976 PRINTCHAR ('^');
1977 size &= PSEUDOVECTOR_SIZE_MASK;
1979 if (size & PSEUDOVECTOR_FLAG)
1980 goto badtype;
1982 PRINTCHAR ('[');
1984 register int i;
1985 register Lisp_Object tem;
1986 ptrdiff_t real_size = size;
1988 /* Don't print more elements than the specified maximum. */
1989 if (NATNUMP (Vprint_length)
1990 && XFASTINT (Vprint_length) < size)
1991 size = XFASTINT (Vprint_length);
1993 for (i = 0; i < size; i++)
1995 if (i) PRINTCHAR (' ');
1996 tem = AREF (obj, i);
1997 print_object (tem, printcharfun, escapeflag);
1999 if (size < real_size)
2000 strout (" ...", 4, 4, printcharfun);
2002 PRINTCHAR (']');
2004 break;
2006 case Lisp_Misc:
2007 switch (XMISCTYPE (obj))
2009 case Lisp_Misc_Marker:
2010 strout ("#<marker ", -1, -1, printcharfun);
2011 /* Do you think this is necessary? */
2012 if (XMARKER (obj)->insertion_type != 0)
2013 strout ("(moves after insertion) ", -1, -1, printcharfun);
2014 if (! XMARKER (obj)->buffer)
2015 strout ("in no buffer", -1, -1, printcharfun);
2016 else
2018 int len = sprintf (buf, "at %"pD"d", marker_position (obj));
2019 strout (buf, len, len, printcharfun);
2020 strout (" in ", -1, -1, printcharfun);
2021 print_string (BVAR (XMARKER (obj)->buffer, name), printcharfun);
2023 PRINTCHAR ('>');
2024 break;
2026 case Lisp_Misc_Overlay:
2027 strout ("#<overlay ", -1, -1, printcharfun);
2028 if (! XMARKER (OVERLAY_START (obj))->buffer)
2029 strout ("in no buffer", -1, -1, printcharfun);
2030 else
2032 int len = sprintf (buf, "from %"pD"d to %"pD"d in ",
2033 marker_position (OVERLAY_START (obj)),
2034 marker_position (OVERLAY_END (obj)));
2035 strout (buf, len, len, printcharfun);
2036 print_string (BVAR (XMARKER (OVERLAY_START (obj))->buffer, name),
2037 printcharfun);
2039 PRINTCHAR ('>');
2040 break;
2042 /* Remaining cases shouldn't happen in normal usage, but let's
2043 print them anyway for the benefit of the debugger. */
2045 case Lisp_Misc_Free:
2046 strout ("#<misc free cell>", -1, -1, printcharfun);
2047 break;
2049 case Lisp_Misc_Save_Value:
2051 int i;
2052 struct Lisp_Save_Value *v = XSAVE_VALUE (obj);
2054 strout ("#<save-value ", -1, -1, printcharfun);
2056 if (v->save_type == SAVE_TYPE_MEMORY)
2058 ptrdiff_t amount = v->data[1].integer;
2060 #if GC_MARK_STACK
2062 /* valid_lisp_object_p is reliable, so try to print up
2063 to 8 saved objects. This code is rarely used, so
2064 it's OK that valid_lisp_object_p is slow. */
2066 int limit = min (amount, 8);
2067 Lisp_Object *area = v->data[0].pointer;
2069 i = sprintf (buf, "with %"pD"d objects", amount);
2070 strout (buf, i, i, printcharfun);
2072 for (i = 0; i < limit; i++)
2074 Lisp_Object maybe = area[i];
2076 if (valid_lisp_object_p (maybe) > 0)
2078 PRINTCHAR (' ');
2079 print_object (maybe, printcharfun, escapeflag);
2081 else
2082 strout (" <invalid>", -1, -1, printcharfun);
2084 if (i == limit && i < amount)
2085 strout (" ...", 4, 4, printcharfun);
2087 #else /* not GC_MARK_STACK */
2089 /* There is no reliable way to determine whether the objects
2090 are initialized, so do not try to print them. */
2092 i = sprintf (buf, "with %"pD"d objects", amount);
2093 strout (buf, i, i, printcharfun);
2095 #endif /* GC_MARK_STACK */
2097 else
2099 /* Print each slot according to its type. */
2100 int index;
2101 for (index = 0; index < SAVE_VALUE_SLOTS; index++)
2103 if (index)
2104 PRINTCHAR (' ');
2106 switch (save_type (v, index))
2108 case SAVE_UNUSED:
2109 i = sprintf (buf, "<unused>");
2110 break;
2112 case SAVE_POINTER:
2113 i = sprintf (buf, "<pointer %p>",
2114 v->data[index].pointer);
2115 break;
2117 case SAVE_FUNCPOINTER:
2118 i = sprintf (buf, "<funcpointer %p>",
2119 ((void *) (intptr_t)
2120 v->data[index].funcpointer));
2121 break;
2123 case SAVE_INTEGER:
2124 i = sprintf (buf, "<integer %"pD"d>",
2125 v->data[index].integer);
2126 break;
2128 case SAVE_OBJECT:
2129 print_object (v->data[index].object, printcharfun,
2130 escapeflag);
2131 continue;
2133 default:
2134 emacs_abort ();
2137 strout (buf, i, i, printcharfun);
2140 PRINTCHAR ('>');
2142 break;
2144 default:
2145 goto badtype;
2147 break;
2149 default:
2150 badtype:
2152 int len;
2153 /* We're in trouble if this happens!
2154 Probably should just emacs_abort (). */
2155 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun);
2156 if (MISCP (obj))
2157 len = sprintf (buf, "(MISC 0x%04x)", (int) XMISCTYPE (obj));
2158 else if (VECTORLIKEP (obj))
2159 len = sprintf (buf, "(PVEC 0x%08"pD"x)", ASIZE (obj));
2160 else
2161 len = sprintf (buf, "(0x%02x)", (int) XTYPE (obj));
2162 strout (buf, len, len, printcharfun);
2163 strout (" Save your buffers immediately and please report this bug>",
2164 -1, -1, printcharfun);
2168 print_depth--;
2172 /* Print a description of INTERVAL using PRINTCHARFUN.
2173 This is part of printing a string that has text properties. */
2175 static void
2176 print_interval (INTERVAL interval, Lisp_Object printcharfun)
2178 if (NILP (interval->plist))
2179 return;
2180 PRINTCHAR (' ');
2181 print_object (make_number (interval->position), printcharfun, 1);
2182 PRINTCHAR (' ');
2183 print_object (make_number (interval->position + LENGTH (interval)),
2184 printcharfun, 1);
2185 PRINTCHAR (' ');
2186 print_object (interval->plist, printcharfun, 1);
2189 /* Initialize debug_print stuff early to have it working from the very
2190 beginning. */
2192 void
2193 init_print_once (void)
2195 DEFSYM (Qexternal_debugging_output, "external-debugging-output");
2196 defsubr (&Sexternal_debugging_output);
2199 void
2200 syms_of_print (void)
2202 DEFSYM (Qtemp_buffer_setup_hook, "temp-buffer-setup-hook");
2204 DEFVAR_LISP ("standard-output", Vstandard_output,
2205 doc: /* Output stream `print' uses by default for outputting a character.
2206 This may be any function of one argument.
2207 It may also be a buffer (output is inserted before point)
2208 or a marker (output is inserted and the marker is advanced)
2209 or the symbol t (output appears in the echo area). */);
2210 Vstandard_output = Qt;
2211 DEFSYM (Qstandard_output, "standard-output");
2213 DEFVAR_LISP ("float-output-format", Vfloat_output_format,
2214 doc: /* The format descriptor string used to print floats.
2215 This is a %-spec like those accepted by `printf' in C,
2216 but with some restrictions. It must start with the two characters `%.'.
2217 After that comes an integer precision specification,
2218 and then a letter which controls the format.
2219 The letters allowed are `e', `f' and `g'.
2220 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2221 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2222 Use `g' to choose the shorter of those two formats for the number at hand.
2223 The precision in any of these cases is the number of digits following
2224 the decimal point. With `f', a precision of 0 means to omit the
2225 decimal point. 0 is not allowed with `e' or `g'.
2227 A value of nil means to use the shortest notation
2228 that represents the number without losing information. */);
2229 Vfloat_output_format = Qnil;
2230 DEFSYM (Qfloat_output_format, "float-output-format");
2232 DEFVAR_LISP ("print-length", Vprint_length,
2233 doc: /* Maximum length of list to print before abbreviating.
2234 A value of nil means no limit. See also `eval-expression-print-length'. */);
2235 Vprint_length = Qnil;
2237 DEFVAR_LISP ("print-level", Vprint_level,
2238 doc: /* Maximum depth of list nesting to print before abbreviating.
2239 A value of nil means no limit. See also `eval-expression-print-level'. */);
2240 Vprint_level = Qnil;
2242 DEFVAR_BOOL ("print-escape-newlines", print_escape_newlines,
2243 doc: /* Non-nil means print newlines in strings as `\\n'.
2244 Also print formfeeds as `\\f'. */);
2245 print_escape_newlines = 0;
2247 DEFVAR_BOOL ("print-escape-nonascii", print_escape_nonascii,
2248 doc: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2249 \(OOO is the octal representation of the character code.)
2250 Only single-byte characters are affected, and only in `prin1'.
2251 When the output goes in a multibyte buffer, this feature is
2252 enabled regardless of the value of the variable. */);
2253 print_escape_nonascii = 0;
2255 DEFVAR_BOOL ("print-escape-multibyte", print_escape_multibyte,
2256 doc: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2257 \(XXXX is the hex representation of the character code.)
2258 This affects only `prin1'. */);
2259 print_escape_multibyte = 0;
2261 DEFVAR_BOOL ("print-quoted", print_quoted,
2262 doc: /* Non-nil means print quoted forms with reader syntax.
2263 I.e., (quote foo) prints as 'foo, (function foo) as #'foo. */);
2264 print_quoted = 0;
2266 DEFVAR_LISP ("print-gensym", Vprint_gensym,
2267 doc: /* Non-nil means print uninterned symbols so they will read as uninterned.
2268 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2269 When the uninterned symbol appears within a recursive data structure,
2270 and the symbol appears more than once, in addition use the #N# and #N=
2271 constructs as needed, so that multiple references to the same symbol are
2272 shared once again when the text is read back. */);
2273 Vprint_gensym = Qnil;
2275 DEFVAR_LISP ("print-circle", Vprint_circle,
2276 doc: /* Non-nil means print recursive structures using #N= and #N# syntax.
2277 If nil, printing proceeds recursively and may lead to
2278 `max-lisp-eval-depth' being exceeded or an error may occur:
2279 \"Apparently circular structure being printed.\" Also see
2280 `print-length' and `print-level'.
2281 If non-nil, shared substructures anywhere in the structure are printed
2282 with `#N=' before the first occurrence (in the order of the print
2283 representation) and `#N#' in place of each subsequent occurrence,
2284 where N is a positive decimal integer. */);
2285 Vprint_circle = Qnil;
2287 DEFVAR_LISP ("print-continuous-numbering", Vprint_continuous_numbering,
2288 doc: /* Non-nil means number continuously across print calls.
2289 This affects the numbers printed for #N= labels and #M# references.
2290 See also `print-circle', `print-gensym', and `print-number-table'.
2291 This variable should not be set with `setq'; bind it with a `let' instead. */);
2292 Vprint_continuous_numbering = Qnil;
2294 DEFVAR_LISP ("print-number-table", Vprint_number_table,
2295 doc: /* A vector used internally to produce `#N=' labels and `#N#' references.
2296 The Lisp printer uses this vector to detect Lisp objects referenced more
2297 than once.
2299 When you bind `print-continuous-numbering' to t, you should probably
2300 also bind `print-number-table' to nil. This ensures that the value of
2301 `print-number-table' can be garbage-collected once the printing is
2302 done. If all elements of `print-number-table' are nil, it means that
2303 the printing done so far has not found any shared structure or objects
2304 that need to be recorded in the table. */);
2305 Vprint_number_table = Qnil;
2307 DEFVAR_LISP ("print-charset-text-property", Vprint_charset_text_property,
2308 doc: /* A flag to control printing of `charset' text property on printing a string.
2309 The value must be nil, t, or `default'.
2311 If the value is nil, don't print the text property `charset'.
2313 If the value is t, always print the text property `charset'.
2315 If the value is `default', print the text property `charset' only when
2316 the value is different from what is guessed in the current charset
2317 priorities. */);
2318 Vprint_charset_text_property = Qdefault;
2320 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2321 staticpro (&Vprin1_to_string_buffer);
2323 defsubr (&Sprin1);
2324 defsubr (&Sprin1_to_string);
2325 defsubr (&Serror_message_string);
2326 defsubr (&Sprinc);
2327 defsubr (&Sprint);
2328 defsubr (&Sterpri);
2329 defsubr (&Swrite_char);
2330 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2331 defsubr (&Sredirect_debugging_output);
2332 #endif
2334 DEFSYM (Qprint_escape_newlines, "print-escape-newlines");
2335 DEFSYM (Qprint_escape_multibyte, "print-escape-multibyte");
2336 DEFSYM (Qprint_escape_nonascii, "print-escape-nonascii");
2338 print_prune_charset_plist = Qnil;
2339 staticpro (&print_prune_charset_plist);