Merged from emacs@sv.gnu.org
[bpt/emacs.git] / src / print.c
1 /* Lisp object printing and output streams.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997,
3 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006, 2007 Free Software Foundation, Inc.
5
6 This file is part of GNU Emacs.
7
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 2, or (at your option)
11 any later version.
12
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.
17
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 Boston, MA 02110-1301, USA. */
22
23
24 #include <config.h>
25 #include <stdio.h>
26 #include "lisp.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
38 Lisp_Object Vstandard_output, Qstandard_output;
39
40 Lisp_Object Qtemp_buffer_setup_hook;
41
42 /* These are used to print like we read. */
43 extern Lisp_Object Qbackquote, Qcomma, Qcomma_at, Qcomma_dot, Qfunction;
44
45 Lisp_Object Vfloat_output_format, Qfloat_output_format;
46
47 /* Work around a problem that happens because math.h on hpux 7
48 defines two static variables--which, in Emacs, are not really static,
49 because `static' is defined as nothing. The problem is that they are
50 defined both here and in lread.c.
51 These macros prevent the name conflict. */
52 #if defined (HPUX) && !defined (HPUX8)
53 #define _MAXLDBL print_maxldbl
54 #define _NMAXLDBL print_nmaxldbl
55 #endif
56
57 #include <math.h>
58
59 #if STDC_HEADERS
60 #include <float.h>
61 #endif
62
63 /* Default to values appropriate for IEEE floating point. */
64 #ifndef FLT_RADIX
65 #define FLT_RADIX 2
66 #endif
67 #ifndef DBL_MANT_DIG
68 #define DBL_MANT_DIG 53
69 #endif
70 #ifndef DBL_DIG
71 #define DBL_DIG 15
72 #endif
73 #ifndef DBL_MIN
74 #define DBL_MIN 2.2250738585072014e-308
75 #endif
76
77 #ifdef DBL_MIN_REPLACEMENT
78 #undef DBL_MIN
79 #define DBL_MIN DBL_MIN_REPLACEMENT
80 #endif
81
82 /* Define DOUBLE_DIGITS_BOUND, an upper bound on the number of decimal digits
83 needed to express a float without losing information.
84 The general-case formula is valid for the usual case, IEEE floating point,
85 but many compilers can't optimize the formula to an integer constant,
86 so make a special case for it. */
87 #if FLT_RADIX == 2 && DBL_MANT_DIG == 53
88 #define DOUBLE_DIGITS_BOUND 17 /* IEEE floating point */
89 #else
90 #define DOUBLE_DIGITS_BOUND ((int) ceil (log10 (pow (FLT_RADIX, DBL_MANT_DIG))))
91 #endif
92
93 /* Avoid actual stack overflow in print. */
94 int print_depth;
95
96 /* Nonzero if inside outputting backquote in old style. */
97 int old_backquote_output;
98
99 /* Detect most circularities to print finite output. */
100 #define PRINT_CIRCLE 200
101 Lisp_Object being_printed[PRINT_CIRCLE];
102
103 /* When printing into a buffer, first we put the text in this
104 block, then insert it all at once. */
105 char *print_buffer;
106
107 /* Size allocated in print_buffer. */
108 int print_buffer_size;
109 /* Chars stored in print_buffer. */
110 int print_buffer_pos;
111 /* Bytes stored in print_buffer. */
112 int print_buffer_pos_byte;
113
114 /* Maximum length of list to print in full; noninteger means
115 effectively infinity */
116
117 Lisp_Object Vprint_length;
118
119 /* Maximum depth of list to print in full; noninteger means
120 effectively infinity. */
121
122 Lisp_Object Vprint_level;
123
124 /* Nonzero means print newlines in strings as \n. */
125
126 int print_escape_newlines;
127
128 /* Nonzero means to print single-byte non-ascii characters in strings as
129 octal escapes. */
130
131 int print_escape_nonascii;
132
133 /* Nonzero means to print multibyte characters in strings as hex escapes. */
134
135 int print_escape_multibyte;
136
137 Lisp_Object Qprint_escape_newlines;
138 Lisp_Object Qprint_escape_multibyte, Qprint_escape_nonascii;
139
140 /* Nonzero means print (quote foo) forms as 'foo, etc. */
141
142 int print_quoted;
143
144 /* Non-nil means print #: before uninterned symbols. */
145
146 Lisp_Object Vprint_gensym;
147
148 /* Non-nil means print recursive structures using #n= and #n# syntax. */
149
150 Lisp_Object Vprint_circle;
151
152 /* Non-nil means keep continuous number for #n= and #n# syntax
153 between several print functions. */
154
155 Lisp_Object Vprint_continuous_numbering;
156
157 /* Vprint_number_table is a vector like [OBJ1 STAT1 OBJ2 STAT2 ...],
158 where OBJn are objects going to be printed, and STATn are their status,
159 which may be different meanings during process. See the comments of
160 the functions print and print_preprocess for details.
161 print_number_index keeps the last position the next object should be added,
162 twice of which is the actual vector position in Vprint_number_table. */
163 int print_number_index;
164 Lisp_Object Vprint_number_table;
165
166 /* PRINT_NUMBER_OBJECT returns the I'th object in Vprint_number_table TABLE.
167 PRINT_NUMBER_STATUS returns the status of the I'th object in TABLE.
168 See the comment of the variable Vprint_number_table. */
169 #define PRINT_NUMBER_OBJECT(table,i) XVECTOR ((table))->contents[(i) * 2]
170 #define PRINT_NUMBER_STATUS(table,i) XVECTOR ((table))->contents[(i) * 2 + 1]
171
172 /* Nonzero means print newline to stdout before next minibuffer message.
173 Defined in xdisp.c */
174
175 extern int noninteractive_need_newline;
176
177 extern int minibuffer_auto_raise;
178
179 #ifdef MAX_PRINT_CHARS
180 static int print_chars;
181 static int max_print;
182 #endif /* MAX_PRINT_CHARS */
183
184 void print_interval ();
185
186 /* GDB resets this to zero on W32 to disable OutputDebugString calls. */
187 int print_output_debug_flag = 1;
188
189 \f
190 /* Low level output routines for characters and strings */
191
192 /* Lisp functions to do output using a stream
193 must have the stream in a variable called printcharfun
194 and must start with PRINTPREPARE, end with PRINTFINISH,
195 and use PRINTDECLARE to declare common variables.
196 Use PRINTCHAR to output one character,
197 or call strout to output a block of characters. */
198
199 #define PRINTDECLARE \
200 struct buffer *old = current_buffer; \
201 int old_point = -1, start_point = -1; \
202 int old_point_byte = -1, start_point_byte = -1; \
203 int specpdl_count = SPECPDL_INDEX (); \
204 int free_print_buffer = 0; \
205 int multibyte = !NILP (current_buffer->enable_multibyte_characters); \
206 Lisp_Object original
207
208 #define PRINTPREPARE \
209 original = printcharfun; \
210 if (NILP (printcharfun)) printcharfun = Qt; \
211 if (BUFFERP (printcharfun)) \
212 { \
213 if (XBUFFER (printcharfun) != current_buffer) \
214 Fset_buffer (printcharfun); \
215 printcharfun = Qnil; \
216 } \
217 if (MARKERP (printcharfun)) \
218 { \
219 EMACS_INT marker_pos; \
220 if (! XMARKER (printcharfun)->buffer) \
221 error ("Marker does not point anywhere"); \
222 if (XMARKER (printcharfun)->buffer != current_buffer) \
223 set_buffer_internal (XMARKER (printcharfun)->buffer); \
224 marker_pos = marker_position (printcharfun); \
225 if (marker_pos < BEGV || marker_pos > ZV) \
226 error ("Marker is outside the accessible part of the buffer"); \
227 old_point = PT; \
228 old_point_byte = PT_BYTE; \
229 SET_PT_BOTH (marker_pos, \
230 marker_byte_position (printcharfun)); \
231 start_point = PT; \
232 start_point_byte = PT_BYTE; \
233 printcharfun = Qnil; \
234 } \
235 if (NILP (printcharfun)) \
236 { \
237 Lisp_Object string; \
238 if (NILP (current_buffer->enable_multibyte_characters) \
239 && ! print_escape_multibyte) \
240 specbind (Qprint_escape_multibyte, Qt); \
241 if (! NILP (current_buffer->enable_multibyte_characters) \
242 && ! print_escape_nonascii) \
243 specbind (Qprint_escape_nonascii, Qt); \
244 if (print_buffer != 0) \
245 { \
246 string = make_string_from_bytes (print_buffer, \
247 print_buffer_pos, \
248 print_buffer_pos_byte); \
249 record_unwind_protect (print_unwind, string); \
250 } \
251 else \
252 { \
253 print_buffer_size = 1000; \
254 print_buffer = (char *) xmalloc (print_buffer_size); \
255 free_print_buffer = 1; \
256 } \
257 print_buffer_pos = 0; \
258 print_buffer_pos_byte = 0; \
259 } \
260 if (EQ (printcharfun, Qt) && ! noninteractive) \
261 setup_echo_area_for_printing (multibyte);
262
263 #define PRINTFINISH \
264 if (NILP (printcharfun)) \
265 { \
266 if (print_buffer_pos != print_buffer_pos_byte \
267 && NILP (current_buffer->enable_multibyte_characters)) \
268 { \
269 unsigned char *temp \
270 = (unsigned char *) alloca (print_buffer_pos + 1); \
271 copy_text (print_buffer, temp, print_buffer_pos_byte, \
272 1, 0); \
273 insert_1_both (temp, print_buffer_pos, \
274 print_buffer_pos, 0, 1, 0); \
275 } \
276 else \
277 insert_1_both (print_buffer, print_buffer_pos, \
278 print_buffer_pos_byte, 0, 1, 0); \
279 signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
280 } \
281 if (free_print_buffer) \
282 { \
283 xfree (print_buffer); \
284 print_buffer = 0; \
285 } \
286 unbind_to (specpdl_count, Qnil); \
287 if (MARKERP (original)) \
288 set_marker_both (original, Qnil, PT, PT_BYTE); \
289 if (old_point >= 0) \
290 SET_PT_BOTH (old_point + (old_point >= start_point \
291 ? PT - start_point : 0), \
292 old_point_byte + (old_point_byte >= start_point_byte \
293 ? PT_BYTE - start_point_byte : 0)); \
294 if (old != current_buffer) \
295 set_buffer_internal (old);
296
297 #define PRINTCHAR(ch) printchar (ch, printcharfun)
298
299 /* This is used to restore the saved contents of print_buffer
300 when there is a recursive call to print. */
301
302 static Lisp_Object
303 print_unwind (saved_text)
304 Lisp_Object saved_text;
305 {
306 bcopy (SDATA (saved_text), print_buffer, SCHARS (saved_text));
307 return Qnil;
308 }
309
310
311 /* Print character CH using method FUN. FUN nil means print to
312 print_buffer. FUN t means print to echo area or stdout if
313 non-interactive. If FUN is neither nil nor t, call FUN with CH as
314 argument. */
315
316 static void
317 printchar (ch, fun)
318 unsigned int ch;
319 Lisp_Object fun;
320 {
321 #ifdef MAX_PRINT_CHARS
322 if (max_print)
323 print_chars++;
324 #endif /* MAX_PRINT_CHARS */
325
326 if (!NILP (fun) && !EQ (fun, Qt))
327 call1 (fun, make_number (ch));
328 else
329 {
330 unsigned char str[MAX_MULTIBYTE_LENGTH];
331 int len = CHAR_STRING (ch, str);
332
333 QUIT;
334
335 if (NILP (fun))
336 {
337 if (print_buffer_pos_byte + len >= print_buffer_size)
338 print_buffer = (char *) xrealloc (print_buffer,
339 print_buffer_size *= 2);
340 bcopy (str, print_buffer + print_buffer_pos_byte, len);
341 print_buffer_pos += 1;
342 print_buffer_pos_byte += len;
343 }
344 else if (noninteractive)
345 {
346 fwrite (str, 1, len, stdout);
347 noninteractive_need_newline = 1;
348 }
349 else
350 {
351 int multibyte_p
352 = !NILP (current_buffer->enable_multibyte_characters);
353
354 setup_echo_area_for_printing (multibyte_p);
355 insert_char (ch);
356 message_dolog (str, len, 0, multibyte_p);
357 }
358 }
359 }
360
361
362 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
363 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
364 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
365 print_buffer. PRINTCHARFUN t means output to the echo area or to
366 stdout if non-interactive. If neither nil nor t, call Lisp
367 function PRINTCHARFUN for each character printed. MULTIBYTE
368 non-zero means PTR contains multibyte characters.
369
370 In the case where PRINTCHARFUN is nil, it is safe for PTR to point
371 to data in a Lisp string. Otherwise that is not safe. */
372
373 static void
374 strout (ptr, size, size_byte, printcharfun, multibyte)
375 char *ptr;
376 int size, size_byte;
377 Lisp_Object printcharfun;
378 int multibyte;
379 {
380 if (size < 0)
381 size_byte = size = strlen (ptr);
382
383 if (NILP (printcharfun))
384 {
385 if (print_buffer_pos_byte + size_byte > print_buffer_size)
386 {
387 print_buffer_size = print_buffer_size * 2 + size_byte;
388 print_buffer = (char *) xrealloc (print_buffer,
389 print_buffer_size);
390 }
391 bcopy (ptr, print_buffer + print_buffer_pos_byte, size_byte);
392 print_buffer_pos += size;
393 print_buffer_pos_byte += size_byte;
394
395 #ifdef MAX_PRINT_CHARS
396 if (max_print)
397 print_chars += size;
398 #endif /* MAX_PRINT_CHARS */
399 }
400 else if (noninteractive && EQ (printcharfun, Qt))
401 {
402 fwrite (ptr, 1, size_byte, stdout);
403 noninteractive_need_newline = 1;
404 }
405 else if (EQ (printcharfun, Qt))
406 {
407 /* Output to echo area. We're trying to avoid a little overhead
408 here, that's the reason we don't call printchar to do the
409 job. */
410 int i;
411 int multibyte_p
412 = !NILP (current_buffer->enable_multibyte_characters);
413
414 setup_echo_area_for_printing (multibyte_p);
415 message_dolog (ptr, size_byte, 0, multibyte_p);
416
417 if (size == size_byte)
418 {
419 for (i = 0; i < size; ++i)
420 insert_char ((unsigned char) *ptr++);
421 }
422 else
423 {
424 int len;
425 for (i = 0; i < size_byte; i += len)
426 {
427 int ch = STRING_CHAR_AND_LENGTH (ptr + i, size_byte - i, len);
428 insert_char (ch);
429 }
430 }
431
432 #ifdef MAX_PRINT_CHARS
433 if (max_print)
434 print_chars += size;
435 #endif /* MAX_PRINT_CHARS */
436 }
437 else
438 {
439 /* PRINTCHARFUN is a Lisp function. */
440 int i = 0;
441
442 if (size == size_byte)
443 {
444 while (i < size_byte)
445 {
446 int ch = ptr[i++];
447 PRINTCHAR (ch);
448 }
449 }
450 else
451 {
452 while (i < size_byte)
453 {
454 /* Here, we must convert each multi-byte form to the
455 corresponding character code before handing it to
456 PRINTCHAR. */
457 int len;
458 int ch = STRING_CHAR_AND_LENGTH (ptr + i, size_byte - i, len);
459 PRINTCHAR (ch);
460 i += len;
461 }
462 }
463 }
464 }
465
466 /* Print the contents of a string STRING using PRINTCHARFUN.
467 It isn't safe to use strout in many cases,
468 because printing one char can relocate. */
469
470 static void
471 print_string (string, printcharfun)
472 Lisp_Object string;
473 Lisp_Object printcharfun;
474 {
475 if (EQ (printcharfun, Qt) || NILP (printcharfun))
476 {
477 int chars;
478
479 if (STRING_MULTIBYTE (string))
480 chars = SCHARS (string);
481 else if (EQ (printcharfun, Qt)
482 ? ! NILP (buffer_defaults.enable_multibyte_characters)
483 : ! NILP (current_buffer->enable_multibyte_characters))
484 {
485 /* If unibyte string STRING contains 8-bit codes, we must
486 convert STRING to a multibyte string containing the same
487 character codes. */
488 Lisp_Object newstr;
489 int bytes;
490
491 chars = SBYTES (string);
492 bytes = parse_str_to_multibyte (SDATA (string), chars);
493 if (chars < bytes)
494 {
495 newstr = make_uninit_multibyte_string (chars, bytes);
496 bcopy (SDATA (string), SDATA (newstr), chars);
497 str_to_multibyte (SDATA (newstr), bytes, chars);
498 string = newstr;
499 }
500 }
501 else
502 chars = SBYTES (string);
503
504 if (EQ (printcharfun, Qt))
505 {
506 /* Output to echo area. */
507 int nbytes = SBYTES (string);
508 char *buffer;
509
510 /* Copy the string contents so that relocation of STRING by
511 GC does not cause trouble. */
512 USE_SAFE_ALLOCA;
513
514 SAFE_ALLOCA (buffer, char *, nbytes);
515 bcopy (SDATA (string), buffer, nbytes);
516
517 strout (buffer, chars, SBYTES (string),
518 printcharfun, STRING_MULTIBYTE (string));
519
520 SAFE_FREE ();
521 }
522 else
523 /* No need to copy, since output to print_buffer can't GC. */
524 strout (SDATA (string),
525 chars, SBYTES (string),
526 printcharfun, STRING_MULTIBYTE (string));
527 }
528 else
529 {
530 /* Otherwise, string may be relocated by printing one char.
531 So re-fetch the string address for each character. */
532 int i;
533 int size = SCHARS (string);
534 int size_byte = SBYTES (string);
535 struct gcpro gcpro1;
536 GCPRO1 (string);
537 if (size == size_byte)
538 for (i = 0; i < size; i++)
539 PRINTCHAR (SREF (string, i));
540 else
541 for (i = 0; i < size_byte; )
542 {
543 /* Here, we must convert each multi-byte form to the
544 corresponding character code before handing it to PRINTCHAR. */
545 int len;
546 int ch = STRING_CHAR_AND_LENGTH (SDATA (string) + i,
547 size_byte - i, len);
548 if (!CHAR_VALID_P (ch, 0))
549 {
550 ch = SREF (string, i);
551 len = 1;
552 }
553 PRINTCHAR (ch);
554 i += len;
555 }
556 UNGCPRO;
557 }
558 }
559 \f
560 DEFUN ("write-char", Fwrite_char, Swrite_char, 1, 2, 0,
561 doc: /* Output character CHARACTER to stream PRINTCHARFUN.
562 PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
563 (character, printcharfun)
564 Lisp_Object character, printcharfun;
565 {
566 PRINTDECLARE;
567
568 if (NILP (printcharfun))
569 printcharfun = Vstandard_output;
570 CHECK_NUMBER (character);
571 PRINTPREPARE;
572 PRINTCHAR (XINT (character));
573 PRINTFINISH;
574 return character;
575 }
576
577 /* Used from outside of print.c to print a block of SIZE
578 single-byte chars at DATA on the default output stream.
579 Do not use this on the contents of a Lisp string. */
580
581 void
582 write_string (data, size)
583 char *data;
584 int size;
585 {
586 PRINTDECLARE;
587 Lisp_Object printcharfun;
588
589 printcharfun = Vstandard_output;
590
591 PRINTPREPARE;
592 strout (data, size, size, printcharfun, 0);
593 PRINTFINISH;
594 }
595
596 /* Used from outside of print.c to print a block of SIZE
597 single-byte chars at DATA on a specified stream PRINTCHARFUN.
598 Do not use this on the contents of a Lisp string. */
599
600 void
601 write_string_1 (data, size, printcharfun)
602 char *data;
603 int size;
604 Lisp_Object printcharfun;
605 {
606 PRINTDECLARE;
607
608 PRINTPREPARE;
609 strout (data, size, size, printcharfun, 0);
610 PRINTFINISH;
611 }
612
613
614 void
615 temp_output_buffer_setup (bufname)
616 const char *bufname;
617 {
618 int count = SPECPDL_INDEX ();
619 register struct buffer *old = current_buffer;
620 register Lisp_Object buf;
621
622 record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ());
623
624 Fset_buffer (Fget_buffer_create (build_string (bufname)));
625
626 Fkill_all_local_variables ();
627 delete_all_overlays (current_buffer);
628 current_buffer->directory = old->directory;
629 current_buffer->read_only = Qnil;
630 current_buffer->filename = Qnil;
631 current_buffer->undo_list = Qt;
632 eassert (current_buffer->overlays_before == NULL);
633 eassert (current_buffer->overlays_after == NULL);
634 current_buffer->enable_multibyte_characters
635 = buffer_defaults.enable_multibyte_characters;
636 specbind (Qinhibit_read_only, Qt);
637 specbind (Qinhibit_modification_hooks, Qt);
638 Ferase_buffer ();
639 XSETBUFFER (buf, current_buffer);
640
641 Frun_hooks (1, &Qtemp_buffer_setup_hook);
642
643 unbind_to (count, Qnil);
644
645 specbind (Qstandard_output, buf);
646 }
647
648 Lisp_Object
649 internal_with_output_to_temp_buffer (bufname, function, args)
650 const char *bufname;
651 Lisp_Object (*function) P_ ((Lisp_Object));
652 Lisp_Object args;
653 {
654 int count = SPECPDL_INDEX ();
655 Lisp_Object buf, val;
656 struct gcpro gcpro1;
657
658 GCPRO1 (args);
659 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
660 temp_output_buffer_setup (bufname);
661 buf = Vstandard_output;
662 UNGCPRO;
663
664 val = (*function) (args);
665
666 GCPRO1 (val);
667 temp_output_buffer_show (buf);
668 UNGCPRO;
669
670 return unbind_to (count, val);
671 }
672
673 DEFUN ("with-output-to-temp-buffer",
674 Fwith_output_to_temp_buffer, Swith_output_to_temp_buffer,
675 1, UNEVALLED, 0,
676 doc: /* Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
677 The buffer is cleared out initially, and marked as unmodified when done.
678 All output done by BODY is inserted in that buffer by default.
679 The buffer is displayed in another window, but not selected.
680 The value of the last form in BODY is returned.
681 If BODY does not finish normally, the buffer BUFNAME is not displayed.
682
683 The hook `temp-buffer-setup-hook' is run before BODY,
684 with the buffer BUFNAME temporarily current.
685 The hook `temp-buffer-show-hook' is run after the buffer is displayed,
686 with the buffer temporarily current, and the window that was used
687 to display it temporarily selected.
688
689 If variable `temp-buffer-show-function' is non-nil, call it at the end
690 to get the buffer displayed instead of just displaying the non-selected
691 buffer and calling the hook. It gets one argument, the buffer to display.
692
693 usage: (with-output-to-temp-buffer BUFNAME BODY ...) */)
694 (args)
695 Lisp_Object args;
696 {
697 struct gcpro gcpro1;
698 Lisp_Object name;
699 int count = SPECPDL_INDEX ();
700 Lisp_Object buf, val;
701
702 GCPRO1(args);
703 name = Feval (Fcar (args));
704 CHECK_STRING (name);
705 temp_output_buffer_setup (SDATA (name));
706 buf = Vstandard_output;
707 UNGCPRO;
708
709 val = Fprogn (XCDR (args));
710
711 GCPRO1 (val);
712 temp_output_buffer_show (buf);
713 UNGCPRO;
714
715 return unbind_to (count, val);
716 }
717
718 \f
719 static void print ();
720 static void print_preprocess ();
721 static void print_preprocess_string ();
722 static void print_object ();
723
724 DEFUN ("terpri", Fterpri, Sterpri, 0, 1, 0,
725 doc: /* Output a newline to stream PRINTCHARFUN.
726 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
727 (printcharfun)
728 Lisp_Object printcharfun;
729 {
730 PRINTDECLARE;
731
732 if (NILP (printcharfun))
733 printcharfun = Vstandard_output;
734 PRINTPREPARE;
735 PRINTCHAR ('\n');
736 PRINTFINISH;
737 return Qt;
738 }
739
740 DEFUN ("prin1", Fprin1, Sprin1, 1, 2, 0,
741 doc: /* Output the printed representation of OBJECT, any Lisp object.
742 Quoting characters are printed when needed to make output that `read'
743 can handle, whenever this is possible. For complex objects, the behavior
744 is controlled by `print-level' and `print-length', which see.
745
746 OBJECT is any of the Lisp data types: a number, a string, a symbol,
747 a list, a buffer, a window, a frame, etc.
748
749 A printed representation of an object is text which describes that object.
750
751 Optional argument PRINTCHARFUN is the output stream, which can be one
752 of these:
753
754 - a buffer, in which case output is inserted into that buffer at point;
755 - a marker, in which case output is inserted at marker's position;
756 - a function, in which case that function is called once for each
757 character of OBJECT's printed representation;
758 - a symbol, in which case that symbol's function definition is called; or
759 - t, in which case the output is displayed in the echo area.
760
761 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
762 is used instead. */)
763 (object, printcharfun)
764 Lisp_Object object, printcharfun;
765 {
766 PRINTDECLARE;
767
768 #ifdef MAX_PRINT_CHARS
769 max_print = 0;
770 #endif /* MAX_PRINT_CHARS */
771 if (NILP (printcharfun))
772 printcharfun = Vstandard_output;
773 PRINTPREPARE;
774 print (object, printcharfun, 1);
775 PRINTFINISH;
776 return object;
777 }
778
779 /* a buffer which is used to hold output being built by prin1-to-string */
780 Lisp_Object Vprin1_to_string_buffer;
781
782 DEFUN ("prin1-to-string", Fprin1_to_string, Sprin1_to_string, 1, 2, 0,
783 doc: /* Return a string containing the printed representation of OBJECT.
784 OBJECT can be any Lisp object. This function outputs quoting characters
785 when necessary to make output that `read' can handle, whenever possible,
786 unless the optional second argument NOESCAPE is non-nil. For complex objects,
787 the behavior is controlled by `print-level' and `print-length', which see.
788
789 OBJECT is any of the Lisp data types: a number, a string, a symbol,
790 a list, a buffer, a window, a frame, etc.
791
792 A printed representation of an object is text which describes that object. */)
793 (object, noescape)
794 Lisp_Object object, noescape;
795 {
796 Lisp_Object printcharfun;
797 /* struct gcpro gcpro1, gcpro2; */
798 Lisp_Object save_deactivate_mark;
799 int count = specpdl_ptr - specpdl;
800 struct buffer *previous;
801
802 specbind (Qinhibit_modification_hooks, Qt);
803
804 {
805 PRINTDECLARE;
806
807 /* Save and restore this--we are altering a buffer
808 but we don't want to deactivate the mark just for that.
809 No need for specbind, since errors deactivate the mark. */
810 save_deactivate_mark = Vdeactivate_mark;
811 /* GCPRO2 (object, save_deactivate_mark); */
812 abort_on_gc++;
813
814 printcharfun = Vprin1_to_string_buffer;
815 PRINTPREPARE;
816 print (object, printcharfun, NILP (noescape));
817 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
818 PRINTFINISH;
819 }
820
821 previous = current_buffer;
822 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
823 object = Fbuffer_string ();
824 if (SBYTES (object) == SCHARS (object))
825 STRING_SET_UNIBYTE (object);
826
827 /* Note that this won't make prepare_to_modify_buffer call
828 ask-user-about-supersession-threat because this buffer
829 does not visit a file. */
830 Ferase_buffer ();
831 set_buffer_internal (previous);
832
833 Vdeactivate_mark = save_deactivate_mark;
834 /* UNGCPRO; */
835
836 abort_on_gc--;
837 return unbind_to (count, object);
838 }
839
840 DEFUN ("princ", Fprinc, Sprinc, 1, 2, 0,
841 doc: /* Output the printed representation of OBJECT, any Lisp object.
842 No quoting characters are used; no delimiters are printed around
843 the contents of strings.
844
845 OBJECT is any of the Lisp data types: a number, a string, a symbol,
846 a list, a buffer, a window, a frame, etc.
847
848 A printed representation of an object is text which describes that object.
849
850 Optional argument PRINTCHARFUN is the output stream, which can be one
851 of these:
852
853 - a buffer, in which case output is inserted into that buffer at point;
854 - a marker, in which case output is inserted at marker's position;
855 - a function, in which case that function is called once for each
856 character of OBJECT's printed representation;
857 - a symbol, in which case that symbol's function definition is called; or
858 - t, in which case the output is displayed in the echo area.
859
860 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
861 is used instead. */)
862 (object, printcharfun)
863 Lisp_Object object, printcharfun;
864 {
865 PRINTDECLARE;
866
867 if (NILP (printcharfun))
868 printcharfun = Vstandard_output;
869 PRINTPREPARE;
870 print (object, printcharfun, 0);
871 PRINTFINISH;
872 return object;
873 }
874
875 DEFUN ("print", Fprint, Sprint, 1, 2, 0,
876 doc: /* Output the printed representation of OBJECT, with newlines around it.
877 Quoting characters are printed when needed to make output that `read'
878 can handle, whenever this is possible. For complex objects, the behavior
879 is controlled by `print-level' and `print-length', which see.
880
881 OBJECT is any of the Lisp data types: a number, a string, a symbol,
882 a list, a buffer, a window, a frame, etc.
883
884 A printed representation of an object is text which describes that object.
885
886 Optional argument PRINTCHARFUN is the output stream, which can be one
887 of these:
888
889 - a buffer, in which case output is inserted into that buffer at point;
890 - a marker, in which case output is inserted at marker's position;
891 - a function, in which case that function is called once for each
892 character of OBJECT's printed representation;
893 - a symbol, in which case that symbol's function definition is called; or
894 - t, in which case the output is displayed in the echo area.
895
896 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
897 is used instead. */)
898 (object, printcharfun)
899 Lisp_Object object, printcharfun;
900 {
901 PRINTDECLARE;
902 struct gcpro gcpro1;
903
904 #ifdef MAX_PRINT_CHARS
905 print_chars = 0;
906 max_print = MAX_PRINT_CHARS;
907 #endif /* MAX_PRINT_CHARS */
908 if (NILP (printcharfun))
909 printcharfun = Vstandard_output;
910 GCPRO1 (object);
911 PRINTPREPARE;
912 PRINTCHAR ('\n');
913 print (object, printcharfun, 1);
914 PRINTCHAR ('\n');
915 PRINTFINISH;
916 #ifdef MAX_PRINT_CHARS
917 max_print = 0;
918 print_chars = 0;
919 #endif /* MAX_PRINT_CHARS */
920 UNGCPRO;
921 return object;
922 }
923
924 /* The subroutine object for external-debugging-output is kept here
925 for the convenience of the debugger. */
926 Lisp_Object Qexternal_debugging_output;
927
928 DEFUN ("external-debugging-output", Fexternal_debugging_output, Sexternal_debugging_output, 1, 1, 0,
929 doc: /* Write CHARACTER to stderr.
930 You can call print while debugging emacs, and pass it this function
931 to make it write to the debugging output. */)
932 (character)
933 Lisp_Object character;
934 {
935 CHECK_NUMBER (character);
936 putc (XINT (character), stderr);
937
938 #ifdef WINDOWSNT
939 /* Send the output to a debugger (nothing happens if there isn't one). */
940 if (print_output_debug_flag)
941 {
942 char buf[2] = {(char) XINT (character), '\0'};
943 OutputDebugString (buf);
944 }
945 #endif
946
947 return character;
948 }
949
950 /* This function is never called. Its purpose is to prevent
951 print_output_debug_flag from being optimized away. */
952
953 void
954 debug_output_compilation_hack (x)
955 int x;
956 {
957 print_output_debug_flag = x;
958 }
959
960 #if defined (GNU_LINUX)
961
962 /* This functionality is not vitally important in general, so we rely on
963 non-portable ability to use stderr as lvalue. */
964
965 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
966
967 FILE *initial_stderr_stream = NULL;
968
969 DEFUN ("redirect-debugging-output", Fredirect_debugging_output, Sredirect_debugging_output,
970 1, 2,
971 "FDebug output file: \nP",
972 doc: /* Redirect debugging output (stderr stream) to file FILE.
973 If FILE is nil, reset target to the initial stderr stream.
974 Optional arg APPEND non-nil (interactively, with prefix arg) means
975 append to existing target file. */)
976 (file, append)
977 Lisp_Object file, append;
978 {
979 if (initial_stderr_stream != NULL)
980 {
981 BLOCK_INPUT;
982 fclose (stderr);
983 UNBLOCK_INPUT;
984 }
985 stderr = initial_stderr_stream;
986 initial_stderr_stream = NULL;
987
988 if (STRINGP (file))
989 {
990 file = Fexpand_file_name (file, Qnil);
991 initial_stderr_stream = stderr;
992 stderr = fopen (SDATA (file), NILP (append) ? "w" : "a");
993 if (stderr == NULL)
994 {
995 stderr = initial_stderr_stream;
996 initial_stderr_stream = NULL;
997 report_file_error ("Cannot open debugging output stream",
998 Fcons (file, Qnil));
999 }
1000 }
1001 return Qnil;
1002 }
1003 #endif /* GNU_LINUX */
1004
1005
1006 /* This is the interface for debugging printing. */
1007
1008 void
1009 debug_print (arg)
1010 Lisp_Object arg;
1011 {
1012 Fprin1 (arg, Qexternal_debugging_output);
1013 fprintf (stderr, "\r\n");
1014 }
1015
1016 void
1017 safe_debug_print (arg)
1018 Lisp_Object arg;
1019 {
1020 int valid = valid_lisp_object_p (arg);
1021
1022 if (valid > 0)
1023 debug_print (arg);
1024 else
1025 fprintf (stderr, "#<%s_LISP_OBJECT 0x%08lx>\r\n",
1026 !valid ? "INVALID" : "SOME",
1027 #ifdef NO_UNION_TYPE
1028 (unsigned long) arg
1029 #else
1030 (unsigned long) arg.i
1031 #endif
1032 );
1033 }
1034
1035 \f
1036 DEFUN ("error-message-string", Ferror_message_string, Serror_message_string,
1037 1, 1, 0,
1038 doc: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
1039 See Info anchor `(elisp)Definition of signal' for some details on how this
1040 error message is constructed. */)
1041 (obj)
1042 Lisp_Object obj;
1043 {
1044 struct buffer *old = current_buffer;
1045 Lisp_Object value;
1046 struct gcpro gcpro1;
1047
1048 /* If OBJ is (error STRING), just return STRING.
1049 That is not only faster, it also avoids the need to allocate
1050 space here when the error is due to memory full. */
1051 if (CONSP (obj) && EQ (XCAR (obj), Qerror)
1052 && CONSP (XCDR (obj))
1053 && STRINGP (XCAR (XCDR (obj)))
1054 && NILP (XCDR (XCDR (obj))))
1055 return XCAR (XCDR (obj));
1056
1057 print_error_message (obj, Vprin1_to_string_buffer, 0, Qnil);
1058
1059 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
1060 value = Fbuffer_string ();
1061
1062 GCPRO1 (value);
1063 Ferase_buffer ();
1064 set_buffer_internal (old);
1065 UNGCPRO;
1066
1067 return value;
1068 }
1069
1070 /* Print an error message for the error DATA onto Lisp output stream
1071 STREAM (suitable for the print functions).
1072 CONTEXT is a C string describing the context of the error.
1073 CALLER is the Lisp function inside which the error was signaled. */
1074
1075 void
1076 print_error_message (data, stream, context, caller)
1077 Lisp_Object data, stream;
1078 char *context;
1079 Lisp_Object caller;
1080 {
1081 Lisp_Object errname, errmsg, file_error, tail;
1082 struct gcpro gcpro1;
1083 int i;
1084
1085 if (context != 0)
1086 write_string_1 (context, -1, stream);
1087
1088 /* If we know from where the error was signaled, show it in
1089 *Messages*. */
1090 if (!NILP (caller) && SYMBOLP (caller))
1091 {
1092 Lisp_Object cname = SYMBOL_NAME (caller);
1093 char *name = alloca (SBYTES (cname));
1094 bcopy (SDATA (cname), name, SBYTES (cname));
1095 message_dolog (name, SBYTES (cname), 0, 0);
1096 message_dolog (": ", 2, 0, 0);
1097 }
1098
1099 errname = Fcar (data);
1100
1101 if (EQ (errname, Qerror))
1102 {
1103 data = Fcdr (data);
1104 if (!CONSP (data))
1105 data = Qnil;
1106 errmsg = Fcar (data);
1107 file_error = Qnil;
1108 }
1109 else
1110 {
1111 Lisp_Object error_conditions;
1112 errmsg = Fget (errname, Qerror_message);
1113 error_conditions = Fget (errname, Qerror_conditions);
1114 file_error = Fmemq (Qfile_error, error_conditions);
1115 }
1116
1117 /* Print an error message including the data items. */
1118
1119 tail = Fcdr_safe (data);
1120 GCPRO1 (tail);
1121
1122 /* For file-error, make error message by concatenating
1123 all the data items. They are all strings. */
1124 if (!NILP (file_error) && CONSP (tail))
1125 errmsg = XCAR (tail), tail = XCDR (tail);
1126
1127 if (STRINGP (errmsg))
1128 Fprinc (errmsg, stream);
1129 else
1130 write_string_1 ("peculiar error", -1, stream);
1131
1132 for (i = 0; CONSP (tail); tail = XCDR (tail), i++)
1133 {
1134 Lisp_Object obj;
1135
1136 write_string_1 (i ? ", " : ": ", 2, stream);
1137 obj = XCAR (tail);
1138 if (!NILP (file_error) || EQ (errname, Qend_of_file))
1139 Fprinc (obj, stream);
1140 else
1141 Fprin1 (obj, stream);
1142 }
1143
1144 UNGCPRO;
1145 }
1146
1147
1148 \f
1149 /*
1150 * The buffer should be at least as large as the max string size of the
1151 * largest float, printed in the biggest notation. This is undoubtedly
1152 * 20d float_output_format, with the negative of the C-constant "HUGE"
1153 * from <math.h>.
1154 *
1155 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
1156 *
1157 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
1158 * case of -1e307 in 20d float_output_format. What is one to do (short of
1159 * re-writing _doprnt to be more sane)?
1160 * -wsr
1161 */
1162
1163 void
1164 float_to_string (buf, data)
1165 unsigned char *buf;
1166 double data;
1167 {
1168 unsigned char *cp;
1169 int width;
1170
1171 /* Check for plus infinity in a way that won't lose
1172 if there is no plus infinity. */
1173 if (data == data / 2 && data > 1.0)
1174 {
1175 strcpy (buf, "1.0e+INF");
1176 return;
1177 }
1178 /* Likewise for minus infinity. */
1179 if (data == data / 2 && data < -1.0)
1180 {
1181 strcpy (buf, "-1.0e+INF");
1182 return;
1183 }
1184 /* Check for NaN in a way that won't fail if there are no NaNs. */
1185 if (! (data * 0.0 >= 0.0))
1186 {
1187 /* Prepend "-" if the NaN's sign bit is negative.
1188 The sign bit of a double is the bit that is 1 in -0.0. */
1189 int i;
1190 union { double d; char c[sizeof (double)]; } u_data, u_minus_zero;
1191 u_data.d = data;
1192 u_minus_zero.d = - 0.0;
1193 for (i = 0; i < sizeof (double); i++)
1194 if (u_data.c[i] & u_minus_zero.c[i])
1195 {
1196 *buf++ = '-';
1197 break;
1198 }
1199
1200 strcpy (buf, "0.0e+NaN");
1201 return;
1202 }
1203
1204 if (NILP (Vfloat_output_format)
1205 || !STRINGP (Vfloat_output_format))
1206 lose:
1207 {
1208 /* Generate the fewest number of digits that represent the
1209 floating point value without losing information.
1210 The following method is simple but a bit slow.
1211 For ideas about speeding things up, please see:
1212
1213 Guy L Steele Jr & Jon L White, How to print floating-point numbers
1214 accurately. SIGPLAN notices 25, 6 (June 1990), 112-126.
1215
1216 Robert G Burger & R Kent Dybvig, Printing floating point numbers
1217 quickly and accurately, SIGPLAN notices 31, 5 (May 1996), 108-116. */
1218
1219 width = fabs (data) < DBL_MIN ? 1 : DBL_DIG;
1220 do
1221 sprintf (buf, "%.*g", width, data);
1222 while (width++ < DOUBLE_DIGITS_BOUND && atof (buf) != data);
1223 }
1224 else /* oink oink */
1225 {
1226 /* Check that the spec we have is fully valid.
1227 This means not only valid for printf,
1228 but meant for floats, and reasonable. */
1229 cp = SDATA (Vfloat_output_format);
1230
1231 if (cp[0] != '%')
1232 goto lose;
1233 if (cp[1] != '.')
1234 goto lose;
1235
1236 cp += 2;
1237
1238 /* Check the width specification. */
1239 width = -1;
1240 if ('0' <= *cp && *cp <= '9')
1241 {
1242 width = 0;
1243 do
1244 width = (width * 10) + (*cp++ - '0');
1245 while (*cp >= '0' && *cp <= '9');
1246
1247 /* A precision of zero is valid only for %f. */
1248 if (width > DBL_DIG
1249 || (width == 0 && *cp != 'f'))
1250 goto lose;
1251 }
1252
1253 if (*cp != 'e' && *cp != 'f' && *cp != 'g')
1254 goto lose;
1255
1256 if (cp[1] != 0)
1257 goto lose;
1258
1259 sprintf (buf, SDATA (Vfloat_output_format), data);
1260 }
1261
1262 /* Make sure there is a decimal point with digit after, or an
1263 exponent, so that the value is readable as a float. But don't do
1264 this with "%.0f"; it's valid for that not to produce a decimal
1265 point. Note that width can be 0 only for %.0f. */
1266 if (width != 0)
1267 {
1268 for (cp = buf; *cp; cp++)
1269 if ((*cp < '0' || *cp > '9') && *cp != '-')
1270 break;
1271
1272 if (*cp == '.' && cp[1] == 0)
1273 {
1274 cp[1] = '0';
1275 cp[2] = 0;
1276 }
1277
1278 if (*cp == 0)
1279 {
1280 *cp++ = '.';
1281 *cp++ = '0';
1282 *cp++ = 0;
1283 }
1284 }
1285 }
1286
1287 \f
1288 static void
1289 print (obj, printcharfun, escapeflag)
1290 Lisp_Object obj;
1291 register Lisp_Object printcharfun;
1292 int escapeflag;
1293 {
1294 old_backquote_output = 0;
1295
1296 /* Reset print_number_index and Vprint_number_table only when
1297 the variable Vprint_continuous_numbering is nil. Otherwise,
1298 the values of these variables will be kept between several
1299 print functions. */
1300 if (NILP (Vprint_continuous_numbering)
1301 || NILP (Vprint_number_table))
1302 {
1303 print_number_index = 0;
1304 Vprint_number_table = Qnil;
1305 }
1306
1307 /* Construct Vprint_number_table for print-gensym and print-circle. */
1308 if (!NILP (Vprint_gensym) || !NILP (Vprint_circle))
1309 {
1310 int i, start, index;
1311 start = index = print_number_index;
1312 /* Construct Vprint_number_table.
1313 This increments print_number_index for the objects added. */
1314 print_depth = 0;
1315 print_preprocess (obj);
1316
1317 /* Remove unnecessary objects, which appear only once in OBJ;
1318 that is, whose status is Qnil. Compactify the necessary objects. */
1319 for (i = start; i < print_number_index; i++)
1320 if (!NILP (PRINT_NUMBER_STATUS (Vprint_number_table, i)))
1321 {
1322 PRINT_NUMBER_OBJECT (Vprint_number_table, index)
1323 = PRINT_NUMBER_OBJECT (Vprint_number_table, i);
1324 index++;
1325 }
1326
1327 /* Clear out objects outside the active part of the table. */
1328 for (i = index; i < print_number_index; i++)
1329 PRINT_NUMBER_OBJECT (Vprint_number_table, i) = Qnil;
1330
1331 /* Reset the status field for the next print step. Now this
1332 field means whether the object has already been printed. */
1333 for (i = start; i < print_number_index; i++)
1334 PRINT_NUMBER_STATUS (Vprint_number_table, i) = Qnil;
1335
1336 print_number_index = index;
1337 }
1338
1339 print_depth = 0;
1340 print_object (obj, printcharfun, escapeflag);
1341 }
1342
1343 /* Construct Vprint_number_table according to the structure of OBJ.
1344 OBJ itself and all its elements will be added to Vprint_number_table
1345 recursively if it is a list, vector, compiled function, char-table,
1346 string (its text properties will be traced), or a symbol that has
1347 no obarray (this is for the print-gensym feature).
1348 The status fields of Vprint_number_table mean whether each object appears
1349 more than once in OBJ: Qnil at the first time, and Qt after that . */
1350 static void
1351 print_preprocess (obj)
1352 Lisp_Object obj;
1353 {
1354 int i;
1355 EMACS_INT size;
1356 int loop_count = 0;
1357 Lisp_Object halftail;
1358
1359 /* Give up if we go so deep that print_object will get an error. */
1360 /* See similar code in print_object. */
1361 if (print_depth >= PRINT_CIRCLE)
1362 error ("Apparently circular structure being printed");
1363
1364 /* Avoid infinite recursion for circular nested structure
1365 in the case where Vprint_circle is nil. */
1366 if (NILP (Vprint_circle))
1367 {
1368 for (i = 0; i < print_depth; i++)
1369 if (EQ (obj, being_printed[i]))
1370 return;
1371 being_printed[print_depth] = obj;
1372 }
1373
1374 print_depth++;
1375 halftail = obj;
1376
1377 loop:
1378 if (STRINGP (obj) || CONSP (obj) || VECTORP (obj)
1379 || COMPILEDP (obj) || CHAR_TABLE_P (obj)
1380 || (! NILP (Vprint_gensym)
1381 && SYMBOLP (obj)
1382 && !SYMBOL_INTERNED_P (obj)))
1383 {
1384 /* In case print-circle is nil and print-gensym is t,
1385 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1386 if (! NILP (Vprint_circle) || SYMBOLP (obj))
1387 {
1388 for (i = 0; i < print_number_index; i++)
1389 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table, i), obj))
1390 {
1391 /* OBJ appears more than once. Let's remember that. */
1392 PRINT_NUMBER_STATUS (Vprint_number_table, i) = Qt;
1393 print_depth--;
1394 return;
1395 }
1396
1397 /* OBJ is not yet recorded. Let's add to the table. */
1398 if (print_number_index == 0)
1399 {
1400 /* Initialize the table. */
1401 Vprint_number_table = Fmake_vector (make_number (40), Qnil);
1402 }
1403 else if (XVECTOR (Vprint_number_table)->size == print_number_index * 2)
1404 {
1405 /* Reallocate the table. */
1406 int i = print_number_index * 4;
1407 Lisp_Object old_table = Vprint_number_table;
1408 Vprint_number_table = Fmake_vector (make_number (i), Qnil);
1409 for (i = 0; i < print_number_index; i++)
1410 {
1411 PRINT_NUMBER_OBJECT (Vprint_number_table, i)
1412 = PRINT_NUMBER_OBJECT (old_table, i);
1413 PRINT_NUMBER_STATUS (Vprint_number_table, i)
1414 = PRINT_NUMBER_STATUS (old_table, i);
1415 }
1416 }
1417 PRINT_NUMBER_OBJECT (Vprint_number_table, print_number_index) = obj;
1418 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1419 always print the gensym with a number. This is a special for
1420 the lisp function byte-compile-output-docform. */
1421 if (!NILP (Vprint_continuous_numbering)
1422 && SYMBOLP (obj)
1423 && !SYMBOL_INTERNED_P (obj))
1424 PRINT_NUMBER_STATUS (Vprint_number_table, print_number_index) = Qt;
1425 print_number_index++;
1426 }
1427
1428 switch (XGCTYPE (obj))
1429 {
1430 case Lisp_String:
1431 /* A string may have text properties, which can be circular. */
1432 traverse_intervals_noorder (STRING_INTERVALS (obj),
1433 print_preprocess_string, Qnil);
1434 break;
1435
1436 case Lisp_Cons:
1437 /* Use HALFTAIL and LOOP_COUNT to detect circular lists,
1438 just as in print_object. */
1439 if (loop_count && EQ (obj, halftail))
1440 break;
1441 print_preprocess (XCAR (obj));
1442 obj = XCDR (obj);
1443 loop_count++;
1444 if (!(loop_count & 1))
1445 halftail = XCDR (halftail);
1446 goto loop;
1447
1448 case Lisp_Vectorlike:
1449 size = XVECTOR (obj)->size;
1450 if (size & PSEUDOVECTOR_FLAG)
1451 size &= PSEUDOVECTOR_SIZE_MASK;
1452 for (i = 0; i < size; i++)
1453 print_preprocess (XVECTOR (obj)->contents[i]);
1454 break;
1455
1456 default:
1457 break;
1458 }
1459 }
1460 print_depth--;
1461 }
1462
1463 static void
1464 print_preprocess_string (interval, arg)
1465 INTERVAL interval;
1466 Lisp_Object arg;
1467 {
1468 print_preprocess (interval->plist);
1469 }
1470
1471 static void
1472 print_object (obj, printcharfun, escapeflag)
1473 Lisp_Object obj;
1474 register Lisp_Object printcharfun;
1475 int escapeflag;
1476 {
1477 char buf[40];
1478
1479 QUIT;
1480
1481 /* Detect circularities and truncate them. */
1482 if (STRINGP (obj) || CONSP (obj) || VECTORP (obj)
1483 || COMPILEDP (obj) || CHAR_TABLE_P (obj)
1484 || (! NILP (Vprint_gensym)
1485 && SYMBOLP (obj)
1486 && !SYMBOL_INTERNED_P (obj)))
1487 {
1488 if (NILP (Vprint_circle) && NILP (Vprint_gensym))
1489 {
1490 /* Simple but incomplete way. */
1491 int i;
1492 for (i = 0; i < print_depth; i++)
1493 if (EQ (obj, being_printed[i]))
1494 {
1495 sprintf (buf, "#%d", i);
1496 strout (buf, -1, -1, printcharfun, 0);
1497 return;
1498 }
1499 being_printed[print_depth] = obj;
1500 }
1501 else
1502 {
1503 /* With the print-circle feature. */
1504 int i;
1505 for (i = 0; i < print_number_index; i++)
1506 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table, i), obj))
1507 {
1508 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table, i)))
1509 {
1510 /* Add a prefix #n= if OBJ has not yet been printed;
1511 that is, its status field is nil. */
1512 sprintf (buf, "#%d=", i + 1);
1513 strout (buf, -1, -1, printcharfun, 0);
1514 /* OBJ is going to be printed. Set the status to t. */
1515 PRINT_NUMBER_STATUS (Vprint_number_table, i) = Qt;
1516 break;
1517 }
1518 else
1519 {
1520 /* Just print #n# if OBJ has already been printed. */
1521 sprintf (buf, "#%d#", i + 1);
1522 strout (buf, -1, -1, printcharfun, 0);
1523 return;
1524 }
1525 }
1526 }
1527 }
1528
1529 print_depth++;
1530
1531 /* See similar code in print_preprocess. */
1532 if (print_depth > PRINT_CIRCLE)
1533 error ("Apparently circular structure being printed");
1534 #ifdef MAX_PRINT_CHARS
1535 if (max_print && print_chars > max_print)
1536 {
1537 PRINTCHAR ('\n');
1538 print_chars = 0;
1539 }
1540 #endif /* MAX_PRINT_CHARS */
1541
1542 switch (XGCTYPE (obj))
1543 {
1544 case Lisp_Int:
1545 if (sizeof (int) == sizeof (EMACS_INT))
1546 sprintf (buf, "%d", XINT (obj));
1547 else if (sizeof (long) == sizeof (EMACS_INT))
1548 sprintf (buf, "%ld", (long) XINT (obj));
1549 else
1550 abort ();
1551 strout (buf, -1, -1, printcharfun, 0);
1552 break;
1553
1554 case Lisp_Float:
1555 {
1556 char pigbuf[350]; /* see comments in float_to_string */
1557
1558 float_to_string (pigbuf, XFLOAT_DATA (obj));
1559 strout (pigbuf, -1, -1, printcharfun, 0);
1560 }
1561 break;
1562
1563 case Lisp_String:
1564 if (!escapeflag)
1565 print_string (obj, printcharfun);
1566 else
1567 {
1568 register int i, i_byte;
1569 struct gcpro gcpro1;
1570 unsigned char *str;
1571 int size_byte;
1572 /* 1 means we must ensure that the next character we output
1573 cannot be taken as part of a hex character escape. */
1574 int need_nonhex = 0;
1575 int multibyte = STRING_MULTIBYTE (obj);
1576
1577 GCPRO1 (obj);
1578
1579 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj)))
1580 {
1581 PRINTCHAR ('#');
1582 PRINTCHAR ('(');
1583 }
1584
1585 PRINTCHAR ('\"');
1586 str = SDATA (obj);
1587 size_byte = SBYTES (obj);
1588
1589 for (i = 0, i_byte = 0; i_byte < size_byte;)
1590 {
1591 /* Here, we must convert each multi-byte form to the
1592 corresponding character code before handing it to PRINTCHAR. */
1593 int len;
1594 int c;
1595
1596 if (multibyte)
1597 {
1598 c = STRING_CHAR_AND_LENGTH (str + i_byte,
1599 size_byte - i_byte, len);
1600 if (CHAR_VALID_P (c, 0))
1601 i_byte += len;
1602 else
1603 c = str[i_byte++];
1604 }
1605 else
1606 c = str[i_byte++];
1607
1608 QUIT;
1609
1610 if (c == '\n' && print_escape_newlines)
1611 {
1612 PRINTCHAR ('\\');
1613 PRINTCHAR ('n');
1614 }
1615 else if (c == '\f' && print_escape_newlines)
1616 {
1617 PRINTCHAR ('\\');
1618 PRINTCHAR ('f');
1619 }
1620 else if (multibyte
1621 && ! ASCII_BYTE_P (c)
1622 && (SINGLE_BYTE_CHAR_P (c) || print_escape_multibyte))
1623 {
1624 /* When multibyte is disabled,
1625 print multibyte string chars using hex escapes.
1626 For a char code that could be in a unibyte string,
1627 when found in a multibyte string, always use a hex escape
1628 so it reads back as multibyte. */
1629 unsigned char outbuf[50];
1630 sprintf (outbuf, "\\x%x", c);
1631 strout (outbuf, -1, -1, printcharfun, 0);
1632 need_nonhex = 1;
1633 }
1634 else if (! multibyte
1635 && SINGLE_BYTE_CHAR_P (c) && ! ASCII_BYTE_P (c)
1636 && print_escape_nonascii)
1637 {
1638 /* When printing in a multibyte buffer
1639 or when explicitly requested,
1640 print single-byte non-ASCII string chars
1641 using octal escapes. */
1642 unsigned char outbuf[5];
1643 sprintf (outbuf, "\\%03o", c);
1644 strout (outbuf, -1, -1, printcharfun, 0);
1645 }
1646 else
1647 {
1648 /* If we just had a hex escape, and this character
1649 could be taken as part of it,
1650 output `\ ' to prevent that. */
1651 if (need_nonhex)
1652 {
1653 need_nonhex = 0;
1654 if ((c >= 'a' && c <= 'f')
1655 || (c >= 'A' && c <= 'F')
1656 || (c >= '0' && c <= '9'))
1657 strout ("\\ ", -1, -1, printcharfun, 0);
1658 }
1659
1660 if (c == '\"' || c == '\\')
1661 PRINTCHAR ('\\');
1662 PRINTCHAR (c);
1663 }
1664 }
1665 PRINTCHAR ('\"');
1666
1667 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj)))
1668 {
1669 traverse_intervals (STRING_INTERVALS (obj),
1670 0, print_interval, printcharfun);
1671 PRINTCHAR (')');
1672 }
1673
1674 UNGCPRO;
1675 }
1676 break;
1677
1678 case Lisp_Symbol:
1679 {
1680 register int confusing;
1681 register unsigned char *p = SDATA (SYMBOL_NAME (obj));
1682 register unsigned char *end = p + SBYTES (SYMBOL_NAME (obj));
1683 register int c;
1684 int i, i_byte, size_byte;
1685 Lisp_Object name;
1686
1687 name = SYMBOL_NAME (obj);
1688
1689 if (p != end && (*p == '-' || *p == '+')) p++;
1690 if (p == end)
1691 confusing = 0;
1692 /* If symbol name begins with a digit, and ends with a digit,
1693 and contains nothing but digits and `e', it could be treated
1694 as a number. So set CONFUSING.
1695
1696 Symbols that contain periods could also be taken as numbers,
1697 but periods are always escaped, so we don't have to worry
1698 about them here. */
1699 else if (*p >= '0' && *p <= '9'
1700 && end[-1] >= '0' && end[-1] <= '9')
1701 {
1702 while (p != end && ((*p >= '0' && *p <= '9')
1703 /* Needed for \2e10. */
1704 || *p == 'e'))
1705 p++;
1706 confusing = (end == p);
1707 }
1708 else
1709 confusing = 0;
1710
1711 if (! NILP (Vprint_gensym) && !SYMBOL_INTERNED_P (obj))
1712 {
1713 PRINTCHAR ('#');
1714 PRINTCHAR (':');
1715 }
1716
1717 size_byte = SBYTES (name);
1718
1719 for (i = 0, i_byte = 0; i_byte < size_byte;)
1720 {
1721 /* Here, we must convert each multi-byte form to the
1722 corresponding character code before handing it to PRINTCHAR. */
1723 FETCH_STRING_CHAR_ADVANCE (c, name, i, i_byte);
1724 QUIT;
1725
1726 if (escapeflag)
1727 {
1728 if (c == '\"' || c == '\\' || c == '\''
1729 || c == ';' || c == '#' || c == '(' || c == ')'
1730 || c == ',' || c =='.' || c == '`'
1731 || c == '[' || c == ']' || c == '?' || c <= 040
1732 || confusing)
1733 PRINTCHAR ('\\'), confusing = 0;
1734 }
1735 PRINTCHAR (c);
1736 }
1737 }
1738 break;
1739
1740 case Lisp_Cons:
1741 /* If deeper than spec'd depth, print placeholder. */
1742 if (INTEGERP (Vprint_level)
1743 && print_depth > XINT (Vprint_level))
1744 strout ("...", -1, -1, printcharfun, 0);
1745 else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
1746 && (EQ (XCAR (obj), Qquote)))
1747 {
1748 PRINTCHAR ('\'');
1749 print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
1750 }
1751 else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
1752 && (EQ (XCAR (obj), Qfunction)))
1753 {
1754 PRINTCHAR ('#');
1755 PRINTCHAR ('\'');
1756 print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
1757 }
1758 else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
1759 && ! old_backquote_output
1760 && ((EQ (XCAR (obj), Qbackquote)
1761 || EQ (XCAR (obj), Qcomma)
1762 || EQ (XCAR (obj), Qcomma_at)
1763 || EQ (XCAR (obj), Qcomma_dot))))
1764 {
1765 print_object (XCAR (obj), printcharfun, 0);
1766 print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
1767 }
1768 else
1769 {
1770 PRINTCHAR ('(');
1771
1772 /* If the first element is a backquote form,
1773 print it old-style so it won't be misunderstood. */
1774 if (print_quoted && CONSP (XCAR (obj))
1775 && CONSP (XCDR (XCAR (obj)))
1776 && NILP (XCDR (XCDR (XCAR (obj))))
1777 && EQ (XCAR (XCAR (obj)), Qbackquote))
1778 {
1779 Lisp_Object tem;
1780 tem = XCAR (obj);
1781 PRINTCHAR ('(');
1782
1783 print_object (Qbackquote, printcharfun, 0);
1784 PRINTCHAR (' ');
1785
1786 ++old_backquote_output;
1787 print_object (XCAR (XCDR (tem)), printcharfun, 0);
1788 --old_backquote_output;
1789 PRINTCHAR (')');
1790
1791 obj = XCDR (obj);
1792 }
1793
1794 {
1795 int print_length, i;
1796 Lisp_Object halftail = obj;
1797
1798 /* Negative values of print-length are invalid in CL.
1799 Treat them like nil, as CMUCL does. */
1800 if (NATNUMP (Vprint_length))
1801 print_length = XFASTINT (Vprint_length);
1802 else
1803 print_length = 0;
1804
1805 i = 0;
1806 while (CONSP (obj))
1807 {
1808 /* Detect circular list. */
1809 if (NILP (Vprint_circle))
1810 {
1811 /* Simple but imcomplete way. */
1812 if (i != 0 && EQ (obj, halftail))
1813 {
1814 sprintf (buf, " . #%d", i / 2);
1815 strout (buf, -1, -1, printcharfun, 0);
1816 goto end_of_list;
1817 }
1818 }
1819 else
1820 {
1821 /* With the print-circle feature. */
1822 if (i != 0)
1823 {
1824 int i;
1825 for (i = 0; i < print_number_index; i++)
1826 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table, i),
1827 obj))
1828 {
1829 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table, i)))
1830 {
1831 strout (" . ", 3, 3, printcharfun, 0);
1832 print_object (obj, printcharfun, escapeflag);
1833 }
1834 else
1835 {
1836 sprintf (buf, " . #%d#", i + 1);
1837 strout (buf, -1, -1, printcharfun, 0);
1838 }
1839 goto end_of_list;
1840 }
1841 }
1842 }
1843
1844 if (i++)
1845 PRINTCHAR (' ');
1846
1847 if (print_length && i > print_length)
1848 {
1849 strout ("...", 3, 3, printcharfun, 0);
1850 goto end_of_list;
1851 }
1852
1853 print_object (XCAR (obj), printcharfun, escapeflag);
1854
1855 obj = XCDR (obj);
1856 if (!(i & 1))
1857 halftail = XCDR (halftail);
1858 }
1859 }
1860
1861 /* OBJ non-nil here means it's the end of a dotted list. */
1862 if (!NILP (obj))
1863 {
1864 strout (" . ", 3, 3, printcharfun, 0);
1865 print_object (obj, printcharfun, escapeflag);
1866 }
1867
1868 end_of_list:
1869 PRINTCHAR (')');
1870 }
1871 break;
1872
1873 case Lisp_Vectorlike:
1874 if (PROCESSP (obj))
1875 {
1876 if (escapeflag)
1877 {
1878 strout ("#<process ", -1, -1, printcharfun, 0);
1879 print_string (XPROCESS (obj)->name, printcharfun);
1880 PRINTCHAR ('>');
1881 }
1882 else
1883 print_string (XPROCESS (obj)->name, printcharfun);
1884 }
1885 else if (BOOL_VECTOR_P (obj))
1886 {
1887 register int i;
1888 register unsigned char c;
1889 struct gcpro gcpro1;
1890 int size_in_chars
1891 = ((XBOOL_VECTOR (obj)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
1892 / BOOL_VECTOR_BITS_PER_CHAR);
1893
1894 GCPRO1 (obj);
1895
1896 PRINTCHAR ('#');
1897 PRINTCHAR ('&');
1898 sprintf (buf, "%ld", (long) XBOOL_VECTOR (obj)->size);
1899 strout (buf, -1, -1, printcharfun, 0);
1900 PRINTCHAR ('\"');
1901
1902 /* Don't print more characters than the specified maximum.
1903 Negative values of print-length are invalid. Treat them
1904 like a print-length of nil. */
1905 if (NATNUMP (Vprint_length)
1906 && XFASTINT (Vprint_length) < size_in_chars)
1907 size_in_chars = XFASTINT (Vprint_length);
1908
1909 for (i = 0; i < size_in_chars; i++)
1910 {
1911 QUIT;
1912 c = XBOOL_VECTOR (obj)->data[i];
1913 if (c == '\n' && print_escape_newlines)
1914 {
1915 PRINTCHAR ('\\');
1916 PRINTCHAR ('n');
1917 }
1918 else if (c == '\f' && print_escape_newlines)
1919 {
1920 PRINTCHAR ('\\');
1921 PRINTCHAR ('f');
1922 }
1923 else if (c > '\177')
1924 {
1925 /* Use octal escapes to avoid encoding issues. */
1926 PRINTCHAR ('\\');
1927 PRINTCHAR ('0' + ((c >> 6) & 3));
1928 PRINTCHAR ('0' + ((c >> 3) & 7));
1929 PRINTCHAR ('0' + (c & 7));
1930 }
1931 else
1932 {
1933 if (c == '\"' || c == '\\')
1934 PRINTCHAR ('\\');
1935 PRINTCHAR (c);
1936 }
1937 }
1938 PRINTCHAR ('\"');
1939
1940 UNGCPRO;
1941 }
1942 else if (SUBRP (obj))
1943 {
1944 strout ("#<subr ", -1, -1, printcharfun, 0);
1945 strout (XSUBR (obj)->symbol_name, -1, -1, printcharfun, 0);
1946 PRINTCHAR ('>');
1947 }
1948 else if (WINDOWP (obj))
1949 {
1950 strout ("#<window ", -1, -1, printcharfun, 0);
1951 sprintf (buf, "%ld", (long) XFASTINT (XWINDOW (obj)->sequence_number));
1952 strout (buf, -1, -1, printcharfun, 0);
1953 if (!NILP (XWINDOW (obj)->buffer))
1954 {
1955 strout (" on ", -1, -1, printcharfun, 0);
1956 print_string (XBUFFER (XWINDOW (obj)->buffer)->name, printcharfun);
1957 }
1958 PRINTCHAR ('>');
1959 }
1960 else if (HASH_TABLE_P (obj))
1961 {
1962 struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
1963 strout ("#<hash-table", -1, -1, printcharfun, 0);
1964 if (SYMBOLP (h->test))
1965 {
1966 PRINTCHAR (' ');
1967 PRINTCHAR ('\'');
1968 strout (SDATA (SYMBOL_NAME (h->test)), -1, -1, printcharfun, 0);
1969 PRINTCHAR (' ');
1970 strout (SDATA (SYMBOL_NAME (h->weak)), -1, -1, printcharfun, 0);
1971 PRINTCHAR (' ');
1972 sprintf (buf, "%ld/%ld", (long) XFASTINT (h->count),
1973 (long) XVECTOR (h->next)->size);
1974 strout (buf, -1, -1, printcharfun, 0);
1975 }
1976 sprintf (buf, " 0x%lx", (unsigned long) h);
1977 strout (buf, -1, -1, printcharfun, 0);
1978 PRINTCHAR ('>');
1979 }
1980 else if (BUFFERP (obj))
1981 {
1982 if (NILP (XBUFFER (obj)->name))
1983 strout ("#<killed buffer>", -1, -1, printcharfun, 0);
1984 else if (escapeflag)
1985 {
1986 strout ("#<buffer ", -1, -1, printcharfun, 0);
1987 print_string (XBUFFER (obj)->name, printcharfun);
1988 PRINTCHAR ('>');
1989 }
1990 else
1991 print_string (XBUFFER (obj)->name, printcharfun);
1992 }
1993 else if (WINDOW_CONFIGURATIONP (obj))
1994 {
1995 strout ("#<window-configuration>", -1, -1, printcharfun, 0);
1996 }
1997 else if (FRAMEP (obj))
1998 {
1999 strout ((FRAME_LIVE_P (XFRAME (obj))
2000 ? "#<frame " : "#<dead frame "),
2001 -1, -1, printcharfun, 0);
2002 print_string (XFRAME (obj)->name, printcharfun);
2003 sprintf (buf, " 0x%lx", (unsigned long) (XFRAME (obj)));
2004 strout (buf, -1, -1, printcharfun, 0);
2005 PRINTCHAR ('>');
2006 }
2007 else
2008 {
2009 EMACS_INT size = XVECTOR (obj)->size;
2010 if (COMPILEDP (obj))
2011 {
2012 PRINTCHAR ('#');
2013 size &= PSEUDOVECTOR_SIZE_MASK;
2014 }
2015 if (CHAR_TABLE_P (obj))
2016 {
2017 /* We print a char-table as if it were a vector,
2018 lumping the parent and default slots in with the
2019 character slots. But we add #^ as a prefix. */
2020 PRINTCHAR ('#');
2021 PRINTCHAR ('^');
2022 if (SUB_CHAR_TABLE_P (obj))
2023 PRINTCHAR ('^');
2024 size &= PSEUDOVECTOR_SIZE_MASK;
2025 }
2026 if (size & PSEUDOVECTOR_FLAG)
2027 goto badtype;
2028
2029 PRINTCHAR ('[');
2030 {
2031 register int i;
2032 register Lisp_Object tem;
2033 int real_size = size;
2034
2035 /* Don't print more elements than the specified maximum. */
2036 if (NATNUMP (Vprint_length)
2037 && XFASTINT (Vprint_length) < size)
2038 size = XFASTINT (Vprint_length);
2039
2040 for (i = 0; i < size; i++)
2041 {
2042 if (i) PRINTCHAR (' ');
2043 tem = XVECTOR (obj)->contents[i];
2044 print_object (tem, printcharfun, escapeflag);
2045 }
2046 if (size < real_size)
2047 strout (" ...", 4, 4, printcharfun, 0);
2048 }
2049 PRINTCHAR (']');
2050 }
2051 break;
2052
2053 case Lisp_Misc:
2054 switch (XMISCTYPE (obj))
2055 {
2056 case Lisp_Misc_Marker:
2057 strout ("#<marker ", -1, -1, printcharfun, 0);
2058 /* Do you think this is necessary? */
2059 if (XMARKER (obj)->insertion_type != 0)
2060 strout ("(moves after insertion) ", -1, -1, printcharfun, 0);
2061 if (! XMARKER (obj)->buffer)
2062 strout ("in no buffer", -1, -1, printcharfun, 0);
2063 else
2064 {
2065 sprintf (buf, "at %d", marker_position (obj));
2066 strout (buf, -1, -1, printcharfun, 0);
2067 strout (" in ", -1, -1, printcharfun, 0);
2068 print_string (XMARKER (obj)->buffer->name, printcharfun);
2069 }
2070 PRINTCHAR ('>');
2071 break;
2072
2073 case Lisp_Misc_Overlay:
2074 strout ("#<overlay ", -1, -1, printcharfun, 0);
2075 if (! XMARKER (OVERLAY_START (obj))->buffer)
2076 strout ("in no buffer", -1, -1, printcharfun, 0);
2077 else
2078 {
2079 sprintf (buf, "from %d to %d in ",
2080 marker_position (OVERLAY_START (obj)),
2081 marker_position (OVERLAY_END (obj)));
2082 strout (buf, -1, -1, printcharfun, 0);
2083 print_string (XMARKER (OVERLAY_START (obj))->buffer->name,
2084 printcharfun);
2085 }
2086 PRINTCHAR ('>');
2087 break;
2088
2089 /* Remaining cases shouldn't happen in normal usage, but let's print
2090 them anyway for the benefit of the debugger. */
2091 case Lisp_Misc_Free:
2092 strout ("#<misc free cell>", -1, -1, printcharfun, 0);
2093 break;
2094
2095 case Lisp_Misc_Intfwd:
2096 sprintf (buf, "#<intfwd to %ld>", (long) *XINTFWD (obj)->intvar);
2097 strout (buf, -1, -1, printcharfun, 0);
2098 break;
2099
2100 case Lisp_Misc_Boolfwd:
2101 sprintf (buf, "#<boolfwd to %s>",
2102 (*XBOOLFWD (obj)->boolvar ? "t" : "nil"));
2103 strout (buf, -1, -1, printcharfun, 0);
2104 break;
2105
2106 case Lisp_Misc_Objfwd:
2107 strout ("#<objfwd to ", -1, -1, printcharfun, 0);
2108 print_object (*XOBJFWD (obj)->objvar, printcharfun, escapeflag);
2109 PRINTCHAR ('>');
2110 break;
2111
2112 case Lisp_Misc_Buffer_Objfwd:
2113 strout ("#<buffer_objfwd to ", -1, -1, printcharfun, 0);
2114 print_object (PER_BUFFER_VALUE (current_buffer,
2115 XBUFFER_OBJFWD (obj)->offset),
2116 printcharfun, escapeflag);
2117 PRINTCHAR ('>');
2118 break;
2119
2120 case Lisp_Misc_Kboard_Objfwd:
2121 strout ("#<kboard_objfwd to ", -1, -1, printcharfun, 0);
2122 print_object (*(Lisp_Object *) ((char *) current_kboard
2123 + XKBOARD_OBJFWD (obj)->offset),
2124 printcharfun, escapeflag);
2125 PRINTCHAR ('>');
2126 break;
2127
2128 case Lisp_Misc_Buffer_Local_Value:
2129 strout ("#<buffer_local_value ", -1, -1, printcharfun, 0);
2130 goto do_buffer_local;
2131 case Lisp_Misc_Some_Buffer_Local_Value:
2132 strout ("#<some_buffer_local_value ", -1, -1, printcharfun, 0);
2133 do_buffer_local:
2134 strout ("[realvalue] ", -1, -1, printcharfun, 0);
2135 print_object (XBUFFER_LOCAL_VALUE (obj)->realvalue,
2136 printcharfun, escapeflag);
2137 if (XBUFFER_LOCAL_VALUE (obj)->found_for_buffer)
2138 strout ("[local in buffer] ", -1, -1, printcharfun, 0);
2139 else
2140 strout ("[buffer] ", -1, -1, printcharfun, 0);
2141 print_object (XBUFFER_LOCAL_VALUE (obj)->buffer,
2142 printcharfun, escapeflag);
2143 if (XBUFFER_LOCAL_VALUE (obj)->check_frame)
2144 {
2145 if (XBUFFER_LOCAL_VALUE (obj)->found_for_frame)
2146 strout ("[local in frame] ", -1, -1, printcharfun, 0);
2147 else
2148 strout ("[frame] ", -1, -1, printcharfun, 0);
2149 print_object (XBUFFER_LOCAL_VALUE (obj)->frame,
2150 printcharfun, escapeflag);
2151 }
2152 strout ("[alist-elt] ", -1, -1, printcharfun, 0);
2153 print_object (XCAR (XBUFFER_LOCAL_VALUE (obj)->cdr),
2154 printcharfun, escapeflag);
2155 strout ("[default-value] ", -1, -1, printcharfun, 0);
2156 print_object (XCDR (XBUFFER_LOCAL_VALUE (obj)->cdr),
2157 printcharfun, escapeflag);
2158 PRINTCHAR ('>');
2159 break;
2160
2161 case Lisp_Misc_Save_Value:
2162 strout ("#<save_value ", -1, -1, printcharfun, 0);
2163 sprintf(buf, "ptr=0x%08lx int=%d",
2164 (unsigned long) XSAVE_VALUE (obj)->pointer,
2165 XSAVE_VALUE (obj)->integer);
2166 strout (buf, -1, -1, printcharfun, 0);
2167 PRINTCHAR ('>');
2168 break;
2169
2170 default:
2171 goto badtype;
2172 }
2173 break;
2174
2175 default:
2176 badtype:
2177 {
2178 /* We're in trouble if this happens!
2179 Probably should just abort () */
2180 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun, 0);
2181 if (MISCP (obj))
2182 sprintf (buf, "(MISC 0x%04x)", (int) XMISCTYPE (obj));
2183 else if (VECTORLIKEP (obj))
2184 sprintf (buf, "(PVEC 0x%08x)", (int) XVECTOR (obj)->size);
2185 else
2186 sprintf (buf, "(0x%02x)", (int) XTYPE (obj));
2187 strout (buf, -1, -1, printcharfun, 0);
2188 strout (" Save your buffers immediately and please report this bug>",
2189 -1, -1, printcharfun, 0);
2190 }
2191 }
2192
2193 print_depth--;
2194 }
2195 \f
2196
2197 /* Print a description of INTERVAL using PRINTCHARFUN.
2198 This is part of printing a string that has text properties. */
2199
2200 void
2201 print_interval (interval, printcharfun)
2202 INTERVAL interval;
2203 Lisp_Object printcharfun;
2204 {
2205 PRINTCHAR (' ');
2206 print_object (make_number (interval->position), printcharfun, 1);
2207 PRINTCHAR (' ');
2208 print_object (make_number (interval->position + LENGTH (interval)),
2209 printcharfun, 1);
2210 PRINTCHAR (' ');
2211 print_object (interval->plist, printcharfun, 1);
2212 }
2213
2214 \f
2215 void
2216 syms_of_print ()
2217 {
2218 Qtemp_buffer_setup_hook = intern ("temp-buffer-setup-hook");
2219 staticpro (&Qtemp_buffer_setup_hook);
2220
2221 DEFVAR_LISP ("standard-output", &Vstandard_output,
2222 doc: /* Output stream `print' uses by default for outputting a character.
2223 This may be any function of one argument.
2224 It may also be a buffer (output is inserted before point)
2225 or a marker (output is inserted and the marker is advanced)
2226 or the symbol t (output appears in the echo area). */);
2227 Vstandard_output = Qt;
2228 Qstandard_output = intern ("standard-output");
2229 staticpro (&Qstandard_output);
2230
2231 DEFVAR_LISP ("float-output-format", &Vfloat_output_format,
2232 doc: /* The format descriptor string used to print floats.
2233 This is a %-spec like those accepted by `printf' in C,
2234 but with some restrictions. It must start with the two characters `%.'.
2235 After that comes an integer precision specification,
2236 and then a letter which controls the format.
2237 The letters allowed are `e', `f' and `g'.
2238 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"
2239 Use `f' for decimal point notation \"DIGITS.DIGITS\".
2240 Use `g' to choose the shorter of those two formats for the number at hand.
2241 The precision in any of these cases is the number of digits following
2242 the decimal point. With `f', a precision of 0 means to omit the
2243 decimal point. 0 is not allowed with `e' or `g'.
2244
2245 A value of nil means to use the shortest notation
2246 that represents the number without losing information. */);
2247 Vfloat_output_format = Qnil;
2248 Qfloat_output_format = intern ("float-output-format");
2249 staticpro (&Qfloat_output_format);
2250
2251 DEFVAR_LISP ("print-length", &Vprint_length,
2252 doc: /* Maximum length of list to print before abbreviating.
2253 A value of nil means no limit. See also `eval-expression-print-length'. */);
2254 Vprint_length = Qnil;
2255
2256 DEFVAR_LISP ("print-level", &Vprint_level,
2257 doc: /* Maximum depth of list nesting to print before abbreviating.
2258 A value of nil means no limit. See also `eval-expression-print-level'. */);
2259 Vprint_level = Qnil;
2260
2261 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines,
2262 doc: /* Non-nil means print newlines in strings as `\\n'.
2263 Also print formfeeds as `\\f'. */);
2264 print_escape_newlines = 0;
2265
2266 DEFVAR_BOOL ("print-escape-nonascii", &print_escape_nonascii,
2267 doc: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
2268 \(OOO is the octal representation of the character code.)
2269 Only single-byte characters are affected, and only in `prin1'.
2270 When the output goes in a multibyte buffer, this feature is
2271 enabled regardless of the value of the variable. */);
2272 print_escape_nonascii = 0;
2273
2274 DEFVAR_BOOL ("print-escape-multibyte", &print_escape_multibyte,
2275 doc: /* Non-nil means print multibyte characters in strings as \\xXXXX.
2276 \(XXXX is the hex representation of the character code.)
2277 This affects only `prin1'. */);
2278 print_escape_multibyte = 0;
2279
2280 DEFVAR_BOOL ("print-quoted", &print_quoted,
2281 doc: /* Non-nil means print quoted forms with reader syntax.
2282 I.e., (quote foo) prints as 'foo, (function foo) as #'foo, and backquoted
2283 forms print as in the new syntax. */);
2284 print_quoted = 0;
2285
2286 DEFVAR_LISP ("print-gensym", &Vprint_gensym,
2287 doc: /* Non-nil means print uninterned symbols so they will read as uninterned.
2288 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.
2289 When the uninterned symbol appears within a recursive data structure,
2290 and the symbol appears more than once, in addition use the #N# and #N=
2291 constructs as needed, so that multiple references to the same symbol are
2292 shared once again when the text is read back. */);
2293 Vprint_gensym = Qnil;
2294
2295 DEFVAR_LISP ("print-circle", &Vprint_circle,
2296 doc: /* *Non-nil means print recursive structures using #N= and #N# syntax.
2297 If nil, printing proceeds recursively and may lead to
2298 `max-lisp-eval-depth' being exceeded or an error may occur:
2299 \"Apparently circular structure being printed.\" Also see
2300 `print-length' and `print-level'.
2301 If non-nil, shared substructures anywhere in the structure are printed
2302 with `#N=' before the first occurrence (in the order of the print
2303 representation) and `#N#' in place of each subsequent occurrence,
2304 where N is a positive decimal integer. */);
2305 Vprint_circle = Qnil;
2306
2307 DEFVAR_LISP ("print-continuous-numbering", &Vprint_continuous_numbering,
2308 doc: /* *Non-nil means number continuously across print calls.
2309 This affects the numbers printed for #N= labels and #M# references.
2310 See also `print-circle', `print-gensym', and `print-number-table'.
2311 This variable should not be set with `setq'; bind it with a `let' instead. */);
2312 Vprint_continuous_numbering = Qnil;
2313
2314 DEFVAR_LISP ("print-number-table", &Vprint_number_table,
2315 doc: /* A vector used internally to produce `#N=' labels and `#N#' references.
2316 The Lisp printer uses this vector to detect Lisp objects referenced more
2317 than once.
2318
2319 When you bind `print-continuous-numbering' to t, you should probably
2320 also bind `print-number-table' to nil. This ensures that the value of
2321 `print-number-table' can be garbage-collected once the printing is
2322 done. If all elements of `print-number-table' are nil, it means that
2323 the printing done so far has not found any shared structure or objects
2324 that need to be recorded in the table. */);
2325 Vprint_number_table = Qnil;
2326
2327 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
2328 staticpro (&Vprin1_to_string_buffer);
2329
2330 defsubr (&Sprin1);
2331 defsubr (&Sprin1_to_string);
2332 defsubr (&Serror_message_string);
2333 defsubr (&Sprinc);
2334 defsubr (&Sprint);
2335 defsubr (&Sterpri);
2336 defsubr (&Swrite_char);
2337 defsubr (&Sexternal_debugging_output);
2338 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2339 defsubr (&Sredirect_debugging_output);
2340 #endif
2341
2342 Qexternal_debugging_output = intern ("external-debugging-output");
2343 staticpro (&Qexternal_debugging_output);
2344
2345 Qprint_escape_newlines = intern ("print-escape-newlines");
2346 staticpro (&Qprint_escape_newlines);
2347
2348 Qprint_escape_multibyte = intern ("print-escape-multibyte");
2349 staticpro (&Qprint_escape_multibyte);
2350
2351 Qprint_escape_nonascii = intern ("print-escape-nonascii");
2352 staticpro (&Qprint_escape_nonascii);
2353
2354 defsubr (&Swith_output_to_temp_buffer);
2355 }
2356
2357 /* arch-tag: bc797170-94ae-41de-86e3-75e20f8f7a39
2358 (do not change this comment) */