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