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