*** empty log message ***
[emacs.git] / src / print.c
blobb6d12f2a9fb34c12633af2534fd06adb5fbe81e9
1 /* Lisp object printing and output streams.
2 Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
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.
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.
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. */
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"
36 Lisp_Object Vstandard_output, Qstandard_output;
38 Lisp_Object Qtemp_buffer_setup_hook;
40 /* These are used to print like we read. */
41 extern Lisp_Object Qbackquote, Qcomma, Qcomma_at, Qcomma_dot, Qfunction;
43 Lisp_Object Vfloat_output_format, Qfloat_output_format;
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
55 #include <math.h>
57 #if STDC_HEADERS
58 #include <float.h>
59 #endif
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
75 #ifdef DBL_MIN_REPLACEMENT
76 #undef DBL_MIN
77 #define DBL_MIN DBL_MIN_REPLACEMENT
78 #endif
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
91 /* Avoid actual stack overflow in print. */
92 int print_depth;
94 /* Detect most circularities to print finite output. */
95 #define PRINT_CIRCLE 200
96 Lisp_Object being_printed[PRINT_CIRCLE];
98 /* When printing into a buffer, first we put the text in this
99 block, then insert it all at once. */
100 char *print_buffer;
102 /* Size allocated in print_buffer. */
103 int print_buffer_size;
104 /* Chars stored in print_buffer. */
105 int print_buffer_pos;
106 /* Bytes stored in print_buffer. */
107 int print_buffer_pos_byte;
109 /* Maximum length of list to print in full; noninteger means
110 effectively infinity */
112 Lisp_Object Vprint_length;
114 /* Maximum depth of list to print in full; noninteger means
115 effectively infinity. */
117 Lisp_Object Vprint_level;
119 /* Nonzero means print newlines in strings as \n. */
121 int print_escape_newlines;
123 /* Nonzero means to print single-byte non-ascii characters in strings as
124 octal escapes. */
126 int print_escape_nonascii;
128 /* Nonzero means to print multibyte characters in strings as hex escapes. */
130 int print_escape_multibyte;
132 Lisp_Object Qprint_escape_newlines;
133 Lisp_Object Qprint_escape_multibyte, Qprint_escape_nonascii;
135 /* Nonzero means print (quote foo) forms as 'foo, etc. */
137 int print_quoted;
139 /* Non-nil means print #: before uninterned symbols. */
141 Lisp_Object Vprint_gensym;
143 /* Non-nil means print recursive structures using #n= and #n# syntax. */
145 Lisp_Object Vprint_circle;
147 /* Non-nil means keep continuous number for #n= and #n# syntax
148 between several print functions. */
150 Lisp_Object Vprint_continuous_numbering;
152 /* Vprint_number_table is a vector like [OBJ1 STAT1 OBJ2 STAT2 ...],
153 where OBJn are objects going to be printed, and STATn are their status,
154 which may be different meanings during process. See the comments of
155 the functions print and print_preprocess for details.
156 print_number_index keeps the last position the next object should be added,
157 twice of which is the actual vector position in Vprint_number_table. */
158 int print_number_index;
159 Lisp_Object Vprint_number_table;
161 /* PRINT_NUMBER_OBJECT returns the I'th object in Vprint_number_table TABLE.
162 PRINT_NUMBER_STATUS returns the status of the I'th object in TABLE.
163 See the comment of the variable Vprint_number_table. */
164 #define PRINT_NUMBER_OBJECT(table,i) XVECTOR ((table))->contents[(i) * 2]
165 #define PRINT_NUMBER_STATUS(table,i) XVECTOR ((table))->contents[(i) * 2 + 1]
167 /* Nonzero means print newline to stdout before next minibuffer message.
168 Defined in xdisp.c */
170 extern int noninteractive_need_newline;
172 extern int minibuffer_auto_raise;
174 #ifdef MAX_PRINT_CHARS
175 static int print_chars;
176 static int max_print;
177 #endif /* MAX_PRINT_CHARS */
179 void print_interval ();
182 /* Low level output routines for characters and strings */
184 /* Lisp functions to do output using a stream
185 must have the stream in a variable called printcharfun
186 and must start with PRINTPREPARE, end with PRINTFINISH,
187 and use PRINTDECLARE to declare common variables.
188 Use PRINTCHAR to output one character,
189 or call strout to output a block of characters. */
191 #define PRINTDECLARE \
192 struct buffer *old = current_buffer; \
193 int old_point = -1, start_point; \
194 int old_point_byte, start_point_byte; \
195 int specpdl_count = specpdl_ptr - specpdl; \
196 int free_print_buffer = 0; \
197 int multibyte = !NILP (current_buffer->enable_multibyte_characters); \
198 Lisp_Object original
200 #define PRINTPREPARE \
201 original = printcharfun; \
202 if (NILP (printcharfun)) printcharfun = Qt; \
203 if (BUFFERP (printcharfun)) \
205 if (XBUFFER (printcharfun) != current_buffer) \
206 Fset_buffer (printcharfun); \
207 printcharfun = Qnil; \
209 if (MARKERP (printcharfun)) \
211 if (!(XMARKER (original)->buffer)) \
212 error ("Marker does not point anywhere"); \
213 if (XMARKER (original)->buffer != current_buffer) \
214 set_buffer_internal (XMARKER (original)->buffer); \
215 old_point = PT; \
216 old_point_byte = PT_BYTE; \
217 SET_PT_BOTH (marker_position (printcharfun), \
218 marker_byte_position (printcharfun)); \
219 start_point = PT; \
220 start_point_byte = PT_BYTE; \
221 printcharfun = Qnil; \
223 if (NILP (printcharfun)) \
225 Lisp_Object string; \
226 if (NILP (current_buffer->enable_multibyte_characters) \
227 && ! print_escape_multibyte) \
228 specbind (Qprint_escape_multibyte, Qt); \
229 if (! NILP (current_buffer->enable_multibyte_characters) \
230 && ! print_escape_nonascii) \
231 specbind (Qprint_escape_nonascii, Qt); \
232 if (print_buffer != 0) \
234 string = make_string_from_bytes (print_buffer, \
235 print_buffer_pos, \
236 print_buffer_pos_byte); \
237 record_unwind_protect (print_unwind, string); \
239 else \
241 print_buffer_size = 1000; \
242 print_buffer = (char *) xmalloc (print_buffer_size); \
243 free_print_buffer = 1; \
245 print_buffer_pos = 0; \
246 print_buffer_pos_byte = 0; \
248 if (EQ (printcharfun, Qt) && ! noninteractive) \
249 setup_echo_area_for_printing (multibyte);
251 #define PRINTFINISH \
252 if (NILP (printcharfun)) \
254 if (print_buffer_pos != print_buffer_pos_byte \
255 && NILP (current_buffer->enable_multibyte_characters)) \
257 unsigned char *temp \
258 = (unsigned char *) alloca (print_buffer_pos + 1); \
259 copy_text (print_buffer, temp, print_buffer_pos_byte, \
260 1, 0); \
261 insert_1_both (temp, print_buffer_pos, \
262 print_buffer_pos, 0, 1, 0); \
264 else \
265 insert_1_both (print_buffer, print_buffer_pos, \
266 print_buffer_pos_byte, 0, 1, 0); \
268 if (free_print_buffer) \
270 xfree (print_buffer); \
271 print_buffer = 0; \
273 unbind_to (specpdl_count, Qnil); \
274 if (MARKERP (original)) \
275 set_marker_both (original, Qnil, PT, PT_BYTE); \
276 if (old_point >= 0) \
277 SET_PT_BOTH (old_point + (old_point >= start_point \
278 ? PT - start_point : 0), \
279 old_point_byte + (old_point_byte >= start_point_byte \
280 ? PT_BYTE - start_point_byte : 0)); \
281 if (old != current_buffer) \
282 set_buffer_internal (old);
284 #define PRINTCHAR(ch) printchar (ch, printcharfun)
286 /* This is used to restore the saved contents of print_buffer
287 when there is a recursive call to print. */
289 static Lisp_Object
290 print_unwind (saved_text)
291 Lisp_Object saved_text;
293 bcopy (XSTRING (saved_text)->data, print_buffer, XSTRING (saved_text)->size);
297 /* Print character CH using method FUN. FUN nil means print to
298 print_buffer. FUN t means print to echo area or stdout if
299 non-interactive. If FUN is neither nil nor t, call FUN with CH as
300 argument. */
302 static void
303 printchar (ch, fun)
304 unsigned int ch;
305 Lisp_Object fun;
307 #ifdef MAX_PRINT_CHARS
308 if (max_print)
309 print_chars++;
310 #endif /* MAX_PRINT_CHARS */
312 if (!NILP (fun) && !EQ (fun, Qt))
313 call1 (fun, make_number (ch));
314 else
316 unsigned char str[MAX_MULTIBYTE_LENGTH];
317 int len = CHAR_STRING (ch, str);
319 QUIT;
321 if (NILP (fun))
323 if (print_buffer_pos_byte + len >= print_buffer_size)
324 print_buffer = (char *) xrealloc (print_buffer,
325 print_buffer_size *= 2);
326 bcopy (str, print_buffer + print_buffer_pos_byte, len);
327 print_buffer_pos += 1;
328 print_buffer_pos_byte += len;
330 else if (noninteractive)
332 fwrite (str, 1, len, stdout);
333 noninteractive_need_newline = 1;
335 else
337 int multibyte_p
338 = !NILP (current_buffer->enable_multibyte_characters);
340 setup_echo_area_for_printing (multibyte_p);
341 insert_char (ch);
342 message_dolog (str, len, 0, multibyte_p);
348 /* Output SIZE characters, SIZE_BYTE bytes from string PTR using
349 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
350 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
351 print_buffer. PRINTCHARFUN t means output to the echo area or to
352 stdout if non-interactive. If neither nil nor t, call Lisp
353 function PRINTCHARFUN for each character printed. MULTIBYTE
354 non-zero means PTR contains multibyte characters. */
356 static void
357 strout (ptr, size, size_byte, printcharfun, multibyte)
358 char *ptr;
359 int size, size_byte;
360 Lisp_Object printcharfun;
361 int multibyte;
363 if (size < 0)
364 size_byte = size = strlen (ptr);
366 if (NILP (printcharfun))
368 if (print_buffer_pos_byte + size_byte > print_buffer_size)
370 print_buffer_size = print_buffer_size * 2 + size_byte;
371 print_buffer = (char *) xrealloc (print_buffer,
372 print_buffer_size);
374 bcopy (ptr, print_buffer + print_buffer_pos_byte, size_byte);
375 print_buffer_pos += size;
376 print_buffer_pos_byte += size_byte;
378 #ifdef MAX_PRINT_CHARS
379 if (max_print)
380 print_chars += size;
381 #endif /* MAX_PRINT_CHARS */
383 else if (noninteractive && EQ (printcharfun, Qt))
385 fwrite (ptr, 1, size_byte, stdout);
386 noninteractive_need_newline = 1;
388 else if (EQ (printcharfun, Qt))
390 /* Output to echo area. We're trying to avoid a little overhead
391 here, that's the reason we don't call printchar to do the
392 job. */
393 int i;
394 int multibyte_p
395 = !NILP (current_buffer->enable_multibyte_characters);
397 setup_echo_area_for_printing (multibyte_p);
398 message_dolog (ptr, size_byte, 0, multibyte_p);
400 if (size == size_byte)
402 for (i = 0; i < size; ++i)
403 insert_char (*ptr++);
405 else
407 int len;
408 for (i = 0; i < size_byte; i += len)
410 int ch = STRING_CHAR_AND_LENGTH (ptr + i, size_byte - i, len);
411 insert_char (ch);
415 #ifdef MAX_PRINT_CHARS
416 if (max_print)
417 print_chars += size;
418 #endif /* MAX_PRINT_CHARS */
420 else
422 /* PRINTCHARFUN is a Lisp function. */
423 int i = 0;
425 if (size == size_byte)
427 while (i < size_byte)
429 int ch = ptr[i++];
430 PRINTCHAR (ch);
433 else
435 while (i < size_byte)
437 /* Here, we must convert each multi-byte form to the
438 corresponding character code before handing it to
439 PRINTCHAR. */
440 int len;
441 int ch = STRING_CHAR_AND_LENGTH (ptr + i, size_byte - i, len);
442 PRINTCHAR (ch);
443 i += len;
449 /* Print the contents of a string STRING using PRINTCHARFUN.
450 It isn't safe to use strout in many cases,
451 because printing one char can relocate. */
453 static void
454 print_string (string, printcharfun)
455 Lisp_Object string;
456 Lisp_Object printcharfun;
458 if (EQ (printcharfun, Qt) || NILP (printcharfun))
460 int chars;
462 if (STRING_MULTIBYTE (string))
463 chars = XSTRING (string)->size;
464 else if (EQ (printcharfun, Qt)
465 ? ! NILP (buffer_defaults.enable_multibyte_characters)
466 : ! NILP (current_buffer->enable_multibyte_characters))
467 chars = multibyte_chars_in_text (XSTRING (string)->data,
468 STRING_BYTES (XSTRING (string)));
469 else
470 chars = STRING_BYTES (XSTRING (string));
472 /* strout is safe for output to a frame (echo area) or to print_buffer. */
473 strout (XSTRING (string)->data,
474 chars, STRING_BYTES (XSTRING (string)),
475 printcharfun, STRING_MULTIBYTE (string));
477 else
479 /* Otherwise, string may be relocated by printing one char.
480 So re-fetch the string address for each character. */
481 int i;
482 int size = XSTRING (string)->size;
483 int size_byte = STRING_BYTES (XSTRING (string));
484 struct gcpro gcpro1;
485 GCPRO1 (string);
486 if (size == size_byte)
487 for (i = 0; i < size; i++)
488 PRINTCHAR (XSTRING (string)->data[i]);
489 else
490 for (i = 0; i < size_byte; i++)
492 /* Here, we must convert each multi-byte form to the
493 corresponding character code before handing it to PRINTCHAR. */
494 int len;
495 int ch = STRING_CHAR_AND_LENGTH (XSTRING (string)->data + i,
496 size_byte - i, len);
497 if (!CHAR_VALID_P (ch, 0))
499 ch = XSTRING (string)->data[i];
500 len = 1;
502 PRINTCHAR (ch);
503 i += len;
505 UNGCPRO;
509 DEFUN ("write-char", Fwrite_char, Swrite_char, 1, 2, 0,
510 "Output character CHARACTER to stream PRINTCHARFUN.\n\
511 PRINTCHARFUN defaults to the value of `standard-output' (which see).")
512 (character, printcharfun)
513 Lisp_Object character, printcharfun;
515 PRINTDECLARE;
517 if (NILP (printcharfun))
518 printcharfun = Vstandard_output;
519 CHECK_NUMBER (character, 0);
520 PRINTPREPARE;
521 PRINTCHAR (XINT (character));
522 PRINTFINISH;
523 return character;
526 /* Used from outside of print.c to print a block of SIZE
527 single-byte chars at DATA on the default output stream.
528 Do not use this on the contents of a Lisp string. */
530 void
531 write_string (data, size)
532 char *data;
533 int size;
535 PRINTDECLARE;
536 Lisp_Object printcharfun;
538 printcharfun = Vstandard_output;
540 PRINTPREPARE;
541 strout (data, size, size, printcharfun, 0);
542 PRINTFINISH;
545 /* Used from outside of print.c to print a block of SIZE
546 single-byte chars at DATA on a specified stream PRINTCHARFUN.
547 Do not use this on the contents of a Lisp string. */
549 void
550 write_string_1 (data, size, printcharfun)
551 char *data;
552 int size;
553 Lisp_Object printcharfun;
555 PRINTDECLARE;
557 PRINTPREPARE;
558 strout (data, size, size, printcharfun, 0);
559 PRINTFINISH;
563 void
564 temp_output_buffer_setup (bufname)
565 char *bufname;
567 int count = specpdl_ptr - specpdl;
568 register struct buffer *old = current_buffer;
569 register Lisp_Object buf;
571 record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ());
573 Fset_buffer (Fget_buffer_create (build_string (bufname)));
575 current_buffer->directory = old->directory;
576 current_buffer->read_only = Qnil;
577 current_buffer->filename = Qnil;
578 current_buffer->undo_list = Qt;
579 current_buffer->overlays_before = Qnil;
580 current_buffer->overlays_after = Qnil;
581 current_buffer->enable_multibyte_characters
582 = buffer_defaults.enable_multibyte_characters;
583 Ferase_buffer ();
584 XSETBUFFER (buf, current_buffer);
586 if (!NILP (Vrun_hooks))
587 call1 (Vrun_hooks, Qtemp_buffer_setup_hook);
589 unbind_to (count, Qnil);
591 specbind (Qstandard_output, buf);
594 Lisp_Object
595 internal_with_output_to_temp_buffer (bufname, function, args)
596 char *bufname;
597 Lisp_Object (*function) P_ ((Lisp_Object));
598 Lisp_Object args;
600 int count = specpdl_ptr - specpdl;
601 Lisp_Object buf, val;
602 struct gcpro gcpro1;
604 GCPRO1 (args);
605 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
606 temp_output_buffer_setup (bufname);
607 buf = Vstandard_output;
608 UNGCPRO;
610 val = (*function) (args);
612 GCPRO1 (val);
613 temp_output_buffer_show (buf);
614 UNGCPRO;
616 return unbind_to (count, val);
619 DEFUN ("with-output-to-temp-buffer", Fwith_output_to_temp_buffer, Swith_output_to_temp_buffer,
620 1, UNEVALLED, 0,
621 "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.\n\
622 The buffer is cleared out initially, and marked as unmodified when done.\n\
623 All output done by BODY is inserted in that buffer by default.\n\
624 The buffer is displayed in another window, but not selected.\n\
625 The value of the last form in BODY is returned.\n\
626 If BODY does not finish normally, the buffer BUFNAME is not displayed.\n\
628 The hook `temp-buffer-setup-hook' is run before BODY,\n\
629 with the buffer BUFNAME temporarily current.\n\
630 The hook `temp-buffer-show-hook' is run after the buffer is displayed,\n\
631 with the buffer temporarily current, and the window that was used\n\
632 to display it temporarily selected.\n\
634 If variable `temp-buffer-show-function' is non-nil, call it at the end\n\
635 to get the buffer displayed instead of just displaying the non-selected\n\
636 buffer and calling the hook. It gets one argument, the buffer to display.")
637 (args)
638 Lisp_Object args;
640 struct gcpro gcpro1;
641 Lisp_Object name;
642 int count = specpdl_ptr - specpdl;
643 Lisp_Object buf, val;
645 GCPRO1(args);
646 name = Feval (Fcar (args));
647 UNGCPRO;
649 CHECK_STRING (name, 0);
650 temp_output_buffer_setup (XSTRING (name)->data);
651 buf = Vstandard_output;
653 val = Fprogn (Fcdr (args));
655 temp_output_buffer_show (buf);
657 return unbind_to (count, val);
661 static void print ();
662 static void print_preprocess ();
663 static void print_preprocess_string ();
664 static void print_object ();
666 DEFUN ("terpri", Fterpri, Sterpri, 0, 1, 0,
667 "Output a newline to stream PRINTCHARFUN.\n\
668 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used.")
669 (printcharfun)
670 Lisp_Object printcharfun;
672 PRINTDECLARE;
674 if (NILP (printcharfun))
675 printcharfun = Vstandard_output;
676 PRINTPREPARE;
677 PRINTCHAR ('\n');
678 PRINTFINISH;
679 return Qt;
682 DEFUN ("prin1", Fprin1, Sprin1, 1, 2, 0,
683 "Output the printed representation of OBJECT, any Lisp object.\n\
684 Quoting characters are printed when needed to make output that `read'\n\
685 can handle, whenever this is possible.\n\
686 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
687 (object, printcharfun)
688 Lisp_Object object, printcharfun;
690 PRINTDECLARE;
692 #ifdef MAX_PRINT_CHARS
693 max_print = 0;
694 #endif /* MAX_PRINT_CHARS */
695 if (NILP (printcharfun))
696 printcharfun = Vstandard_output;
697 PRINTPREPARE;
698 print (object, printcharfun, 1);
699 PRINTFINISH;
700 return object;
703 /* a buffer which is used to hold output being built by prin1-to-string */
704 Lisp_Object Vprin1_to_string_buffer;
706 DEFUN ("prin1-to-string", Fprin1_to_string, Sprin1_to_string, 1, 2, 0,
707 "Return a string containing the printed representation of OBJECT,\n\
708 any Lisp object. Quoting characters are used when needed to make output\n\
709 that `read' can handle, whenever this is possible, unless the optional\n\
710 second argument NOESCAPE is non-nil.")
711 (object, noescape)
712 Lisp_Object object, noescape;
714 PRINTDECLARE;
715 Lisp_Object printcharfun;
716 struct gcpro gcpro1, gcpro2;
717 Lisp_Object tem;
719 /* Save and restore this--we are altering a buffer
720 but we don't want to deactivate the mark just for that.
721 No need for specbind, since errors deactivate the mark. */
722 tem = Vdeactivate_mark;
723 GCPRO2 (object, tem);
725 printcharfun = Vprin1_to_string_buffer;
726 PRINTPREPARE;
727 print (object, printcharfun, NILP (noescape));
728 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
729 PRINTFINISH;
730 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
731 object = Fbuffer_string ();
733 Ferase_buffer ();
734 set_buffer_internal (old);
736 Vdeactivate_mark = tem;
737 UNGCPRO;
739 return object;
742 DEFUN ("princ", Fprinc, Sprinc, 1, 2, 0,
743 "Output the printed representation of OBJECT, any Lisp object.\n\
744 No quoting characters are used; no delimiters are printed around\n\
745 the contents of strings.\n\
746 Output stream is PRINTCHARFUN, or value of standard-output (which see).")
747 (object, printcharfun)
748 Lisp_Object object, printcharfun;
750 PRINTDECLARE;
752 if (NILP (printcharfun))
753 printcharfun = Vstandard_output;
754 PRINTPREPARE;
755 print (object, printcharfun, 0);
756 PRINTFINISH;
757 return object;
760 DEFUN ("print", Fprint, Sprint, 1, 2, 0,
761 "Output the printed representation of OBJECT, with newlines around it.\n\
762 Quoting characters are printed when needed to make output that `read'\n\
763 can handle, whenever this is possible.\n\
764 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
765 (object, printcharfun)
766 Lisp_Object object, printcharfun;
768 PRINTDECLARE;
769 struct gcpro gcpro1;
771 #ifdef MAX_PRINT_CHARS
772 print_chars = 0;
773 max_print = MAX_PRINT_CHARS;
774 #endif /* MAX_PRINT_CHARS */
775 if (NILP (printcharfun))
776 printcharfun = Vstandard_output;
777 GCPRO1 (object);
778 PRINTPREPARE;
779 PRINTCHAR ('\n');
780 print (object, printcharfun, 1);
781 PRINTCHAR ('\n');
782 PRINTFINISH;
783 #ifdef MAX_PRINT_CHARS
784 max_print = 0;
785 print_chars = 0;
786 #endif /* MAX_PRINT_CHARS */
787 UNGCPRO;
788 return object;
791 /* The subroutine object for external-debugging-output is kept here
792 for the convenience of the debugger. */
793 Lisp_Object Qexternal_debugging_output;
795 DEFUN ("external-debugging-output", Fexternal_debugging_output, Sexternal_debugging_output, 1, 1, 0,
796 "Write CHARACTER to stderr.\n\
797 You can call print while debugging emacs, and pass it this function\n\
798 to make it write to the debugging output.\n")
799 (character)
800 Lisp_Object character;
802 CHECK_NUMBER (character, 0);
803 putc (XINT (character), stderr);
805 #ifdef WINDOWSNT
806 /* Send the output to a debugger (nothing happens if there isn't one). */
808 char buf[2] = {(char) XINT (character), '\0'};
809 OutputDebugString (buf);
811 #endif
813 return character;
816 /* This is the interface for debugging printing. */
818 void
819 debug_print (arg)
820 Lisp_Object arg;
822 Fprin1 (arg, Qexternal_debugging_output);
823 fprintf (stderr, "\r\n");
826 DEFUN ("error-message-string", Ferror_message_string, Serror_message_string,
827 1, 1, 0,
828 "Convert an error value (ERROR-SYMBOL . DATA) to an error message.")
829 (obj)
830 Lisp_Object obj;
832 struct buffer *old = current_buffer;
833 Lisp_Object value;
834 struct gcpro gcpro1;
836 /* If OBJ is (error STRING), just return STRING.
837 That is not only faster, it also avoids the need to allocate
838 space here when the error is due to memory full. */
839 if (CONSP (obj) && EQ (XCAR (obj), Qerror)
840 && CONSP (XCDR (obj))
841 && STRINGP (XCAR (XCDR (obj)))
842 && NILP (XCDR (XCDR (obj))))
843 return XCAR (XCDR (obj));
845 print_error_message (obj, Vprin1_to_string_buffer);
847 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
848 value = Fbuffer_string ();
850 GCPRO1 (value);
851 Ferase_buffer ();
852 set_buffer_internal (old);
853 UNGCPRO;
855 return value;
858 /* Print an error message for the error DATA onto Lisp output stream
859 STREAM (suitable for the print functions). */
861 void
862 print_error_message (data, stream)
863 Lisp_Object data, stream;
865 Lisp_Object errname, errmsg, file_error, tail;
866 struct gcpro gcpro1;
867 int i;
869 errname = Fcar (data);
871 if (EQ (errname, Qerror))
873 data = Fcdr (data);
874 if (!CONSP (data))
875 data = Qnil;
876 errmsg = Fcar (data);
877 file_error = Qnil;
879 else
881 Lisp_Object error_conditions;
882 errmsg = Fget (errname, Qerror_message);
883 error_conditions = Fget (errname, Qerror_conditions);
884 file_error = Fmemq (Qfile_error, error_conditions);
887 /* Print an error message including the data items. */
889 tail = Fcdr_safe (data);
890 GCPRO1 (tail);
892 /* If we know from where the error was signaled, show it in
893 *Messages*. */
894 if (!NILP (Vsignaling_function) && SYMBOLP (Vsignaling_function))
896 char *name = XSYMBOL (Vsignaling_function)->name->data;
897 message_dolog (name, strlen (name), 0, 0);
898 message_dolog (": ", 2, 0, 0);
899 Vsignaling_function = Qnil;
902 /* For file-error, make error message by concatenating
903 all the data items. They are all strings. */
904 if (!NILP (file_error) && CONSP (tail))
905 errmsg = XCAR (tail), tail = XCDR (tail);
907 if (STRINGP (errmsg))
908 Fprinc (errmsg, stream);
909 else
910 write_string_1 ("peculiar error", -1, stream);
912 for (i = 0; CONSP (tail); tail = XCDR (tail), i++)
914 Lisp_Object obj;
916 write_string_1 (i ? ", " : ": ", 2, stream);
917 obj = XCAR (tail);
918 if (!NILP (file_error) || EQ (errname, Qend_of_file))
919 Fprinc (obj, stream);
920 else
921 Fprin1 (obj, stream);
924 UNGCPRO;
930 * The buffer should be at least as large as the max string size of the
931 * largest float, printed in the biggest notation. This is undoubtedly
932 * 20d float_output_format, with the negative of the C-constant "HUGE"
933 * from <math.h>.
935 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
937 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
938 * case of -1e307 in 20d float_output_format. What is one to do (short of
939 * re-writing _doprnt to be more sane)?
940 * -wsr
943 void
944 float_to_string (buf, data)
945 unsigned char *buf;
946 double data;
948 unsigned char *cp;
949 int width;
951 /* Check for plus infinity in a way that won't lose
952 if there is no plus infinity. */
953 if (data == data / 2 && data > 1.0)
955 strcpy (buf, "1.0e+INF");
956 return;
958 /* Likewise for minus infinity. */
959 if (data == data / 2 && data < -1.0)
961 strcpy (buf, "-1.0e+INF");
962 return;
964 /* Check for NaN in a way that won't fail if there are no NaNs. */
965 if (! (data * 0.0 >= 0.0))
967 /* Prepend "-" if the NaN's sign bit is negative.
968 The sign bit of a double is the bit that is 1 in -0.0. */
969 int i;
970 union { double d; char c[sizeof (double)]; } u_data, u_minus_zero;
971 u_data.d = data;
972 u_minus_zero.d = - 0.0;
973 for (i = 0; i < sizeof (double); i++)
974 if (u_data.c[i] & u_minus_zero.c[i])
976 *buf++ = '-';
977 break;
980 strcpy (buf, "0.0e+NaN");
981 return;
984 if (NILP (Vfloat_output_format)
985 || !STRINGP (Vfloat_output_format))
986 lose:
988 /* Generate the fewest number of digits that represent the
989 floating point value without losing information.
990 The following method is simple but a bit slow.
991 For ideas about speeding things up, please see:
993 Guy L Steele Jr & Jon L White, How to print floating-point numbers
994 accurately. SIGPLAN notices 25, 6 (June 1990), 112-126.
996 Robert G Burger & R Kent Dybvig, Printing floating point numbers
997 quickly and accurately, SIGPLAN notices 31, 5 (May 1996), 108-116. */
999 width = fabs (data) < DBL_MIN ? 1 : DBL_DIG;
1001 sprintf (buf, "%.*g", width, data);
1002 while (width++ < DOUBLE_DIGITS_BOUND && atof (buf) != data);
1004 else /* oink oink */
1006 /* Check that the spec we have is fully valid.
1007 This means not only valid for printf,
1008 but meant for floats, and reasonable. */
1009 cp = XSTRING (Vfloat_output_format)->data;
1011 if (cp[0] != '%')
1012 goto lose;
1013 if (cp[1] != '.')
1014 goto lose;
1016 cp += 2;
1018 /* Check the width specification. */
1019 width = -1;
1020 if ('0' <= *cp && *cp <= '9')
1022 width = 0;
1024 width = (width * 10) + (*cp++ - '0');
1025 while (*cp >= '0' && *cp <= '9');
1027 /* A precision of zero is valid only for %f. */
1028 if (width > DBL_DIG
1029 || (width == 0 && *cp != 'f'))
1030 goto lose;
1033 if (*cp != 'e' && *cp != 'f' && *cp != 'g')
1034 goto lose;
1036 if (cp[1] != 0)
1037 goto lose;
1039 sprintf (buf, XSTRING (Vfloat_output_format)->data, data);
1042 /* Make sure there is a decimal point with digit after, or an
1043 exponent, so that the value is readable as a float. But don't do
1044 this with "%.0f"; it's valid for that not to produce a decimal
1045 point. Note that width can be 0 only for %.0f. */
1046 if (width != 0)
1048 for (cp = buf; *cp; cp++)
1049 if ((*cp < '0' || *cp > '9') && *cp != '-')
1050 break;
1052 if (*cp == '.' && cp[1] == 0)
1054 cp[1] = '0';
1055 cp[2] = 0;
1058 if (*cp == 0)
1060 *cp++ = '.';
1061 *cp++ = '0';
1062 *cp++ = 0;
1068 static void
1069 print (obj, printcharfun, escapeflag)
1070 Lisp_Object obj;
1071 register Lisp_Object printcharfun;
1072 int escapeflag;
1074 print_depth = 0;
1076 /* Reset print_number_index and Vprint_number_table only when
1077 the variable Vprint_continuous_numbering is nil. Otherwise,
1078 the values of these variables will be kept between several
1079 print functions. */
1080 if (NILP (Vprint_continuous_numbering))
1082 print_number_index = 0;
1083 Vprint_number_table = Qnil;
1086 /* Construct Vprint_number_table for print-gensym and print-circle. */
1087 if (!NILP (Vprint_gensym) || !NILP (Vprint_circle))
1089 int i, start, index;
1090 /* Construct Vprint_number_table. */
1091 start = index = print_number_index;
1092 print_preprocess (obj);
1093 /* Remove unnecessary objects, which appear only once in OBJ;
1094 that is, whose status is Qnil. */
1095 for (i = start; i < print_number_index; i++)
1096 if (!NILP (PRINT_NUMBER_STATUS (Vprint_number_table, i)))
1098 PRINT_NUMBER_OBJECT (Vprint_number_table, index)
1099 = PRINT_NUMBER_OBJECT (Vprint_number_table, i);
1100 /* Reset the status field for the next print step. Now this
1101 field means whether the object has already been printed. */
1102 PRINT_NUMBER_STATUS (Vprint_number_table, index) = Qnil;
1103 index++;
1105 print_number_index = index;
1108 print_object (obj, printcharfun, escapeflag);
1111 /* Construct Vprint_number_table according to the structure of OBJ.
1112 OBJ itself and all its elements will be added to Vprint_number_table
1113 recursively if it is a list, vector, compiled function, char-table,
1114 string (its text properties will be traced), or a symbol that has
1115 no obarray (this is for the print-gensym feature).
1116 The status fields of Vprint_number_table mean whether each object appears
1117 more than once in OBJ: Qnil at the first time, and Qt after that . */
1118 static void
1119 print_preprocess (obj)
1120 Lisp_Object obj;
1122 int i, size;
1124 loop:
1125 if (STRINGP (obj) || CONSP (obj) || VECTORP (obj)
1126 || COMPILEDP (obj) || CHAR_TABLE_P (obj)
1127 || (! NILP (Vprint_gensym)
1128 && SYMBOLP (obj) && NILP (XSYMBOL (obj)->obarray)))
1130 /* In case print-circle is nil and print-gensym is t,
1131 add OBJ to Vprint_number_table only when OBJ is a symbol. */
1132 if (! NILP (Vprint_circle) || SYMBOLP (obj))
1134 for (i = 0; i < print_number_index; i++)
1135 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table, i), obj))
1137 /* OBJ appears more than once. Let's remember that. */
1138 PRINT_NUMBER_STATUS (Vprint_number_table, i) = Qt;
1139 return;
1142 /* OBJ is not yet recorded. Let's add to the table. */
1143 if (print_number_index == 0)
1145 /* Initialize the table. */
1146 Vprint_number_table = Fmake_vector (make_number (40), Qnil);
1148 else if (XVECTOR (Vprint_number_table)->size == print_number_index * 2)
1150 /* Reallocate the table. */
1151 int i = print_number_index * 4;
1152 Lisp_Object old_table = Vprint_number_table;
1153 Vprint_number_table = Fmake_vector (make_number (i), Qnil);
1154 for (i = 0; i < print_number_index; i++)
1156 PRINT_NUMBER_OBJECT (Vprint_number_table, i)
1157 = PRINT_NUMBER_OBJECT (old_table, i);
1158 PRINT_NUMBER_STATUS (Vprint_number_table, i)
1159 = PRINT_NUMBER_STATUS (old_table, i);
1162 PRINT_NUMBER_OBJECT (Vprint_number_table, print_number_index) = obj;
1163 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
1164 always print the gensym with a number. This is a special for
1165 the lisp function byte-compile-output-docform. */
1166 if (! NILP (Vprint_continuous_numbering) && SYMBOLP (obj)
1167 && NILP (XSYMBOL (obj)->obarray))
1168 PRINT_NUMBER_STATUS (Vprint_number_table, print_number_index) = Qt;
1169 print_number_index++;
1172 switch (XGCTYPE (obj))
1174 case Lisp_String:
1175 /* A string may have text properties, which can be circular. */
1176 traverse_intervals (XSTRING (obj)->intervals, 0, 0,
1177 print_preprocess_string, Qnil);
1178 break;
1180 case Lisp_Cons:
1181 print_preprocess (XCAR (obj));
1182 obj = XCDR (obj);
1183 goto loop;
1185 case Lisp_Vectorlike:
1186 size = XVECTOR (obj)->size & PSEUDOVECTOR_SIZE_MASK;
1187 for (i = 0; i < size; i++)
1188 print_preprocess (XVECTOR (obj)->contents[i]);
1193 static void
1194 print_preprocess_string (interval, arg)
1195 INTERVAL interval;
1196 Lisp_Object arg;
1198 print_preprocess (interval->plist);
1201 static void
1202 print_object (obj, printcharfun, escapeflag)
1203 Lisp_Object obj;
1204 register Lisp_Object printcharfun;
1205 int escapeflag;
1207 char buf[30];
1209 QUIT;
1211 /* Detect circularities and truncate them. */
1212 if (STRINGP (obj) || CONSP (obj) || VECTORP (obj)
1213 || COMPILEDP (obj) || CHAR_TABLE_P (obj)
1214 || (! NILP (Vprint_gensym)
1215 && SYMBOLP (obj) && NILP (XSYMBOL (obj)->obarray)))
1217 if (NILP (Vprint_circle) && NILP (Vprint_gensym))
1219 /* Simple but incomplete way. */
1220 int i;
1221 for (i = 0; i < print_depth; i++)
1222 if (EQ (obj, being_printed[i]))
1224 sprintf (buf, "#%d", i);
1225 strout (buf, -1, -1, printcharfun, 0);
1226 return;
1228 being_printed[print_depth] = obj;
1230 else
1232 /* With the print-circle feature. */
1233 int i;
1234 for (i = 0; i < print_number_index; i++)
1235 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table, i), obj))
1237 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table, i)))
1239 /* Add a prefix #n= if OBJ has not yet been printed;
1240 that is, its status field is nil. */
1241 sprintf (buf, "#%d=", i + 1);
1242 strout (buf, -1, -1, printcharfun, 0);
1243 /* OBJ is going to be printed. Set the status to t. */
1244 PRINT_NUMBER_STATUS (Vprint_number_table, i) = Qt;
1245 break;
1247 else
1249 /* Just print #n# if OBJ has already been printed. */
1250 sprintf (buf, "#%d#", i + 1);
1251 strout (buf, -1, -1, printcharfun, 0);
1252 return;
1258 print_depth++;
1260 if (print_depth > PRINT_CIRCLE)
1261 error ("Apparently circular structure being printed");
1262 #ifdef MAX_PRINT_CHARS
1263 if (max_print && print_chars > max_print)
1265 PRINTCHAR ('\n');
1266 print_chars = 0;
1268 #endif /* MAX_PRINT_CHARS */
1270 switch (XGCTYPE (obj))
1272 case Lisp_Int:
1273 if (sizeof (int) == sizeof (EMACS_INT))
1274 sprintf (buf, "%d", XINT (obj));
1275 else if (sizeof (long) == sizeof (EMACS_INT))
1276 sprintf (buf, "%ld", (long) XINT (obj));
1277 else
1278 abort ();
1279 strout (buf, -1, -1, printcharfun, 0);
1280 break;
1282 case Lisp_Float:
1284 char pigbuf[350]; /* see comments in float_to_string */
1286 float_to_string (pigbuf, XFLOAT_DATA (obj));
1287 strout (pigbuf, -1, -1, printcharfun, 0);
1289 break;
1291 case Lisp_String:
1292 if (!escapeflag)
1293 print_string (obj, printcharfun);
1294 else
1296 register int i, i_byte;
1297 struct gcpro gcpro1;
1298 unsigned char *str;
1299 int size_byte;
1300 /* 1 means we must ensure that the next character we output
1301 cannot be taken as part of a hex character escape. */
1302 int need_nonhex = 0;
1304 GCPRO1 (obj);
1306 if (!NULL_INTERVAL_P (XSTRING (obj)->intervals))
1308 PRINTCHAR ('#');
1309 PRINTCHAR ('(');
1312 PRINTCHAR ('\"');
1313 str = XSTRING (obj)->data;
1314 size_byte = STRING_BYTES (XSTRING (obj));
1316 for (i = 0, i_byte = 0; i_byte < size_byte;)
1318 /* Here, we must convert each multi-byte form to the
1319 corresponding character code before handing it to PRINTCHAR. */
1320 int len;
1321 int c;
1323 if (STRING_MULTIBYTE (obj))
1325 c = STRING_CHAR_AND_LENGTH (str + i_byte,
1326 size_byte - i_byte, len);
1327 if (CHAR_VALID_P (c, 0))
1328 i_byte += len;
1329 else
1330 c = str[i_byte++];
1332 else
1333 c = str[i_byte++];
1335 QUIT;
1337 if (c == '\n' && print_escape_newlines)
1339 PRINTCHAR ('\\');
1340 PRINTCHAR ('n');
1342 else if (c == '\f' && print_escape_newlines)
1344 PRINTCHAR ('\\');
1345 PRINTCHAR ('f');
1347 else if (! SINGLE_BYTE_CHAR_P (c) && print_escape_multibyte)
1349 /* When multibyte is disabled,
1350 print multibyte string chars using hex escapes. */
1351 unsigned char outbuf[50];
1352 sprintf (outbuf, "\\x%x", c);
1353 strout (outbuf, -1, -1, printcharfun, 0);
1354 need_nonhex = 1;
1356 else if (SINGLE_BYTE_CHAR_P (c) && ! ASCII_BYTE_P (c)
1357 && print_escape_nonascii)
1359 /* When printing in a multibyte buffer
1360 or when explicitly requested,
1361 print single-byte non-ASCII string chars
1362 using octal escapes. */
1363 unsigned char outbuf[5];
1364 sprintf (outbuf, "\\%03o", c);
1365 strout (outbuf, -1, -1, printcharfun, 0);
1367 else
1369 /* If we just had a hex escape, and this character
1370 could be taken as part of it,
1371 output `\ ' to prevent that. */
1372 if (need_nonhex)
1374 need_nonhex = 0;
1375 if ((c >= 'a' && c <= 'f')
1376 || (c >= 'A' && c <= 'F')
1377 || (c >= '0' && c <= '9'))
1378 strout ("\\ ", -1, -1, printcharfun, 0);
1381 if (c == '\"' || c == '\\')
1382 PRINTCHAR ('\\');
1383 PRINTCHAR (c);
1386 PRINTCHAR ('\"');
1388 if (!NULL_INTERVAL_P (XSTRING (obj)->intervals))
1390 traverse_intervals (XSTRING (obj)->intervals,
1391 0, 0, print_interval, printcharfun);
1392 PRINTCHAR (')');
1395 UNGCPRO;
1397 break;
1399 case Lisp_Symbol:
1401 register int confusing;
1402 register unsigned char *p = XSYMBOL (obj)->name->data;
1403 register unsigned char *end = p + STRING_BYTES (XSYMBOL (obj)->name);
1404 register int c;
1405 int i, i_byte, size_byte;
1406 Lisp_Object name;
1408 XSETSTRING (name, XSYMBOL (obj)->name);
1410 if (p != end && (*p == '-' || *p == '+')) p++;
1411 if (p == end)
1412 confusing = 0;
1413 /* If symbol name begins with a digit, and ends with a digit,
1414 and contains nothing but digits and `e', it could be treated
1415 as a number. So set CONFUSING.
1417 Symbols that contain periods could also be taken as numbers,
1418 but periods are always escaped, so we don't have to worry
1419 about them here. */
1420 else if (*p >= '0' && *p <= '9'
1421 && end[-1] >= '0' && end[-1] <= '9')
1423 while (p != end && ((*p >= '0' && *p <= '9')
1424 /* Needed for \2e10. */
1425 || *p == 'e'))
1426 p++;
1427 confusing = (end == p);
1429 else
1430 confusing = 0;
1432 if (! NILP (Vprint_gensym) && NILP (XSYMBOL (obj)->obarray))
1434 PRINTCHAR ('#');
1435 PRINTCHAR (':');
1438 size_byte = STRING_BYTES (XSTRING (name));
1440 for (i = 0, i_byte = 0; i_byte < size_byte;)
1442 /* Here, we must convert each multi-byte form to the
1443 corresponding character code before handing it to PRINTCHAR. */
1444 FETCH_STRING_CHAR_ADVANCE (c, name, i, i_byte);
1445 QUIT;
1447 if (escapeflag)
1449 if (c == '\"' || c == '\\' || c == '\''
1450 || c == ';' || c == '#' || c == '(' || c == ')'
1451 || c == ',' || c =='.' || c == '`'
1452 || c == '[' || c == ']' || c == '?' || c <= 040
1453 || confusing)
1454 PRINTCHAR ('\\'), confusing = 0;
1456 PRINTCHAR (c);
1459 break;
1461 case Lisp_Cons:
1462 /* If deeper than spec'd depth, print placeholder. */
1463 if (INTEGERP (Vprint_level)
1464 && print_depth > XINT (Vprint_level))
1465 strout ("...", -1, -1, printcharfun, 0);
1466 else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
1467 && (EQ (XCAR (obj), Qquote)))
1469 PRINTCHAR ('\'');
1470 print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
1472 else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
1473 && (EQ (XCAR (obj), Qfunction)))
1475 PRINTCHAR ('#');
1476 PRINTCHAR ('\'');
1477 print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
1479 else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
1480 && ((EQ (XCAR (obj), Qbackquote)
1481 || EQ (XCAR (obj), Qcomma)
1482 || EQ (XCAR (obj), Qcomma_at)
1483 || EQ (XCAR (obj), Qcomma_dot))))
1485 print_object (XCAR (obj), printcharfun, 0);
1486 print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
1488 else
1490 PRINTCHAR ('(');
1492 int print_length, i;
1493 Lisp_Object halftail = obj;
1495 /* Negative values of print-length are invalid in CL.
1496 Treat them like nil, as CMUCL does. */
1497 if (NATNUMP (Vprint_length))
1498 print_length = XFASTINT (Vprint_length);
1499 else
1500 print_length = 0;
1502 i = 0;
1503 while (CONSP (obj))
1505 /* Detect circular list. */
1506 if (NILP (Vprint_circle))
1508 /* Simple but imcomplete way. */
1509 if (i != 0 && EQ (obj, halftail))
1511 sprintf (buf, " . #%d", i / 2);
1512 strout (buf, -1, -1, printcharfun, 0);
1513 goto end_of_list;
1516 else
1518 /* With the print-circle feature. */
1519 if (i != 0)
1521 int i;
1522 for (i = 0; i < print_number_index; i++)
1523 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table, i),
1524 obj))
1526 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table, i)))
1528 strout (" . ", 3, 3, printcharfun, 0);
1529 print_object (obj, printcharfun, escapeflag);
1531 else
1533 sprintf (buf, " . #%d#", i + 1);
1534 strout (buf, -1, -1, printcharfun, 0);
1536 goto end_of_list;
1541 if (i++)
1542 PRINTCHAR (' ');
1544 if (print_length && i > print_length)
1546 strout ("...", 3, 3, printcharfun, 0);
1547 goto end_of_list;
1550 print_object (XCAR (obj), printcharfun, escapeflag);
1552 obj = XCDR (obj);
1553 if (!(i & 1))
1554 halftail = XCDR (halftail);
1558 /* OBJ non-nil here means it's the end of a dotted list. */
1559 if (!NILP (obj))
1561 strout (" . ", 3, 3, printcharfun, 0);
1562 print_object (obj, printcharfun, escapeflag);
1565 end_of_list:
1566 PRINTCHAR (')');
1568 break;
1570 case Lisp_Vectorlike:
1571 if (PROCESSP (obj))
1573 if (escapeflag)
1575 strout ("#<process ", -1, -1, printcharfun, 0);
1576 print_string (XPROCESS (obj)->name, printcharfun);
1577 PRINTCHAR ('>');
1579 else
1580 print_string (XPROCESS (obj)->name, printcharfun);
1582 else if (BOOL_VECTOR_P (obj))
1584 register int i;
1585 register unsigned char c;
1586 struct gcpro gcpro1;
1587 int size_in_chars
1588 = (XBOOL_VECTOR (obj)->size + BITS_PER_CHAR - 1) / BITS_PER_CHAR;
1590 GCPRO1 (obj);
1592 PRINTCHAR ('#');
1593 PRINTCHAR ('&');
1594 sprintf (buf, "%d", XBOOL_VECTOR (obj)->size);
1595 strout (buf, -1, -1, printcharfun, 0);
1596 PRINTCHAR ('\"');
1598 /* Don't print more characters than the specified maximum.
1599 Negative values of print-length are invalid. Treat them
1600 like a print-length of nil. */
1601 if (NATNUMP (Vprint_length)
1602 && XFASTINT (Vprint_length) < size_in_chars)
1603 size_in_chars = XFASTINT (Vprint_length);
1605 for (i = 0; i < size_in_chars; i++)
1607 QUIT;
1608 c = XBOOL_VECTOR (obj)->data[i];
1609 if (c == '\n' && print_escape_newlines)
1611 PRINTCHAR ('\\');
1612 PRINTCHAR ('n');
1614 else if (c == '\f' && print_escape_newlines)
1616 PRINTCHAR ('\\');
1617 PRINTCHAR ('f');
1619 else
1621 if (c == '\"' || c == '\\')
1622 PRINTCHAR ('\\');
1623 PRINTCHAR (c);
1626 PRINTCHAR ('\"');
1628 UNGCPRO;
1630 else if (SUBRP (obj))
1632 strout ("#<subr ", -1, -1, printcharfun, 0);
1633 strout (XSUBR (obj)->symbol_name, -1, -1, printcharfun, 0);
1634 PRINTCHAR ('>');
1636 else if (WINDOWP (obj))
1638 strout ("#<window ", -1, -1, printcharfun, 0);
1639 sprintf (buf, "%d", XFASTINT (XWINDOW (obj)->sequence_number));
1640 strout (buf, -1, -1, printcharfun, 0);
1641 if (!NILP (XWINDOW (obj)->buffer))
1643 strout (" on ", -1, -1, printcharfun, 0);
1644 print_string (XBUFFER (XWINDOW (obj)->buffer)->name, printcharfun);
1646 PRINTCHAR ('>');
1648 else if (HASH_TABLE_P (obj))
1650 struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
1651 strout ("#<hash-table", -1, -1, printcharfun, 0);
1652 if (SYMBOLP (h->test))
1654 PRINTCHAR (' ');
1655 PRINTCHAR ('\'');
1656 strout (XSYMBOL (h->test)->name->data, -1, -1, printcharfun, 0);
1657 PRINTCHAR (' ');
1658 strout (XSYMBOL (h->weak)->name->data, -1, -1, printcharfun, 0);
1659 PRINTCHAR (' ');
1660 sprintf (buf, "%d/%d", XFASTINT (h->count),
1661 XVECTOR (h->next)->size);
1662 strout (buf, -1, -1, printcharfun, 0);
1664 sprintf (buf, " 0x%lx", (unsigned long) h);
1665 strout (buf, -1, -1, printcharfun, 0);
1666 PRINTCHAR ('>');
1668 else if (BUFFERP (obj))
1670 if (NILP (XBUFFER (obj)->name))
1671 strout ("#<killed buffer>", -1, -1, printcharfun, 0);
1672 else if (escapeflag)
1674 strout ("#<buffer ", -1, -1, printcharfun, 0);
1675 print_string (XBUFFER (obj)->name, printcharfun);
1676 PRINTCHAR ('>');
1678 else
1679 print_string (XBUFFER (obj)->name, printcharfun);
1681 else if (WINDOW_CONFIGURATIONP (obj))
1683 strout ("#<window-configuration>", -1, -1, printcharfun, 0);
1685 else if (FRAMEP (obj))
1687 strout ((FRAME_LIVE_P (XFRAME (obj))
1688 ? "#<frame " : "#<dead frame "),
1689 -1, -1, printcharfun, 0);
1690 print_string (XFRAME (obj)->name, printcharfun);
1691 sprintf (buf, " 0x%lx\\ ", (unsigned long) (XFRAME (obj)));
1692 strout (buf, -1, -1, printcharfun, 0);
1693 PRINTCHAR ('>');
1695 else
1697 int size = XVECTOR (obj)->size;
1698 if (COMPILEDP (obj))
1700 PRINTCHAR ('#');
1701 size &= PSEUDOVECTOR_SIZE_MASK;
1703 if (CHAR_TABLE_P (obj))
1705 /* We print a char-table as if it were a vector,
1706 lumping the parent and default slots in with the
1707 character slots. But we add #^ as a prefix. */
1708 PRINTCHAR ('#');
1709 PRINTCHAR ('^');
1710 if (SUB_CHAR_TABLE_P (obj))
1711 PRINTCHAR ('^');
1712 size &= PSEUDOVECTOR_SIZE_MASK;
1714 if (size & PSEUDOVECTOR_FLAG)
1715 goto badtype;
1717 PRINTCHAR ('[');
1719 register int i;
1720 register Lisp_Object tem;
1721 int real_size = size;
1723 /* Don't print more elements than the specified maximum. */
1724 if (NATNUMP (Vprint_length)
1725 && XFASTINT (Vprint_length) < size)
1726 size = XFASTINT (Vprint_length);
1728 for (i = 0; i < size; i++)
1730 if (i) PRINTCHAR (' ');
1731 tem = XVECTOR (obj)->contents[i];
1732 print_object (tem, printcharfun, escapeflag);
1734 if (size < real_size)
1735 strout (" ...", 4, 4, printcharfun, 0);
1737 PRINTCHAR (']');
1739 break;
1741 case Lisp_Misc:
1742 switch (XMISCTYPE (obj))
1744 case Lisp_Misc_Marker:
1745 strout ("#<marker ", -1, -1, printcharfun, 0);
1746 /* Do you think this is necessary? */
1747 if (XMARKER (obj)->insertion_type != 0)
1748 strout ("(before-insertion) ", -1, -1, printcharfun, 0);
1749 if (!(XMARKER (obj)->buffer))
1750 strout ("in no buffer", -1, -1, printcharfun, 0);
1751 else
1753 sprintf (buf, "at %d", marker_position (obj));
1754 strout (buf, -1, -1, printcharfun, 0);
1755 strout (" in ", -1, -1, printcharfun, 0);
1756 print_string (XMARKER (obj)->buffer->name, printcharfun);
1758 PRINTCHAR ('>');
1759 break;
1761 case Lisp_Misc_Overlay:
1762 strout ("#<overlay ", -1, -1, printcharfun, 0);
1763 if (!(XMARKER (OVERLAY_START (obj))->buffer))
1764 strout ("in no buffer", -1, -1, printcharfun, 0);
1765 else
1767 sprintf (buf, "from %d to %d in ",
1768 marker_position (OVERLAY_START (obj)),
1769 marker_position (OVERLAY_END (obj)));
1770 strout (buf, -1, -1, printcharfun, 0);
1771 print_string (XMARKER (OVERLAY_START (obj))->buffer->name,
1772 printcharfun);
1774 PRINTCHAR ('>');
1775 break;
1777 /* Remaining cases shouldn't happen in normal usage, but let's print
1778 them anyway for the benefit of the debugger. */
1779 case Lisp_Misc_Free:
1780 strout ("#<misc free cell>", -1, -1, printcharfun, 0);
1781 break;
1783 case Lisp_Misc_Intfwd:
1784 sprintf (buf, "#<intfwd to %d>", *XINTFWD (obj)->intvar);
1785 strout (buf, -1, -1, printcharfun, 0);
1786 break;
1788 case Lisp_Misc_Boolfwd:
1789 sprintf (buf, "#<boolfwd to %s>",
1790 (*XBOOLFWD (obj)->boolvar ? "t" : "nil"));
1791 strout (buf, -1, -1, printcharfun, 0);
1792 break;
1794 case Lisp_Misc_Objfwd:
1795 strout ("#<objfwd to ", -1, -1, printcharfun, 0);
1796 print_object (*XOBJFWD (obj)->objvar, printcharfun, escapeflag);
1797 PRINTCHAR ('>');
1798 break;
1800 case Lisp_Misc_Buffer_Objfwd:
1801 strout ("#<buffer_objfwd to ", -1, -1, printcharfun, 0);
1802 print_object (PER_BUFFER_VALUE (current_buffer,
1803 XBUFFER_OBJFWD (obj)->offset),
1804 printcharfun, escapeflag);
1805 PRINTCHAR ('>');
1806 break;
1808 case Lisp_Misc_Kboard_Objfwd:
1809 strout ("#<kboard_objfwd to ", -1, -1, printcharfun, 0);
1810 print_object (*(Lisp_Object *)((char *) current_kboard
1811 + XKBOARD_OBJFWD (obj)->offset),
1812 printcharfun, escapeflag);
1813 PRINTCHAR ('>');
1814 break;
1816 case Lisp_Misc_Buffer_Local_Value:
1817 strout ("#<buffer_local_value ", -1, -1, printcharfun, 0);
1818 goto do_buffer_local;
1819 case Lisp_Misc_Some_Buffer_Local_Value:
1820 strout ("#<some_buffer_local_value ", -1, -1, printcharfun, 0);
1821 do_buffer_local:
1822 strout ("[realvalue] ", -1, -1, printcharfun, 0);
1823 print_object (XBUFFER_LOCAL_VALUE (obj)->realvalue,
1824 printcharfun, escapeflag);
1825 if (XBUFFER_LOCAL_VALUE (obj)->found_for_buffer)
1826 strout ("[local in buffer] ", -1, -1, printcharfun, 0);
1827 else
1828 strout ("[buffer] ", -1, -1, printcharfun, 0);
1829 print_object (XBUFFER_LOCAL_VALUE (obj)->buffer,
1830 printcharfun, escapeflag);
1831 if (XBUFFER_LOCAL_VALUE (obj)->check_frame)
1833 if (XBUFFER_LOCAL_VALUE (obj)->found_for_frame)
1834 strout ("[local in frame] ", -1, -1, printcharfun, 0);
1835 else
1836 strout ("[frame] ", -1, -1, printcharfun, 0);
1837 print_object (XBUFFER_LOCAL_VALUE (obj)->frame,
1838 printcharfun, escapeflag);
1840 strout ("[alist-elt] ", -1, -1, printcharfun, 0);
1841 print_object (XCAR (XBUFFER_LOCAL_VALUE (obj)->cdr),
1842 printcharfun, escapeflag);
1843 strout ("[default-value] ", -1, -1, printcharfun, 0);
1844 print_object (XCDR (XBUFFER_LOCAL_VALUE (obj)->cdr),
1845 printcharfun, escapeflag);
1846 PRINTCHAR ('>');
1847 break;
1849 default:
1850 goto badtype;
1852 break;
1854 default:
1855 badtype:
1857 /* We're in trouble if this happens!
1858 Probably should just abort () */
1859 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun, 0);
1860 if (MISCP (obj))
1861 sprintf (buf, "(MISC 0x%04x)", (int) XMISCTYPE (obj));
1862 else if (VECTORLIKEP (obj))
1863 sprintf (buf, "(PVEC 0x%08x)", (int) XVECTOR (obj)->size);
1864 else
1865 sprintf (buf, "(0x%02x)", (int) XTYPE (obj));
1866 strout (buf, -1, -1, printcharfun, 0);
1867 strout (" Save your buffers immediately and please report this bug>",
1868 -1, -1, printcharfun, 0);
1872 print_depth--;
1876 /* Print a description of INTERVAL using PRINTCHARFUN.
1877 This is part of printing a string that has text properties. */
1879 void
1880 print_interval (interval, printcharfun)
1881 INTERVAL interval;
1882 Lisp_Object printcharfun;
1884 PRINTCHAR (' ');
1885 print_object (make_number (interval->position), printcharfun, 1);
1886 PRINTCHAR (' ');
1887 print_object (make_number (interval->position + LENGTH (interval)),
1888 printcharfun, 1);
1889 PRINTCHAR (' ');
1890 print_object (interval->plist, printcharfun, 1);
1894 void
1895 syms_of_print ()
1897 Qtemp_buffer_setup_hook = intern ("temp-buffer-setup-hook");
1898 staticpro (&Qtemp_buffer_setup_hook);
1900 DEFVAR_LISP ("standard-output", &Vstandard_output,
1901 "Output stream `print' uses by default for outputting a character.\n\
1902 This may be any function of one argument.\n\
1903 It may also be a buffer (output is inserted before point)\n\
1904 or a marker (output is inserted and the marker is advanced)\n\
1905 or the symbol t (output appears in the echo area).");
1906 Vstandard_output = Qt;
1907 Qstandard_output = intern ("standard-output");
1908 staticpro (&Qstandard_output);
1910 DEFVAR_LISP ("float-output-format", &Vfloat_output_format,
1911 "The format descriptor string used to print floats.\n\
1912 This is a %-spec like those accepted by `printf' in C,\n\
1913 but with some restrictions. It must start with the two characters `%.'.\n\
1914 After that comes an integer precision specification,\n\
1915 and then a letter which controls the format.\n\
1916 The letters allowed are `e', `f' and `g'.\n\
1917 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"\n\
1918 Use `f' for decimal point notation \"DIGITS.DIGITS\".\n\
1919 Use `g' to choose the shorter of those two formats for the number at hand.\n\
1920 The precision in any of these cases is the number of digits following\n\
1921 the decimal point. With `f', a precision of 0 means to omit the\n\
1922 decimal point. 0 is not allowed with `e' or `g'.\n\n\
1923 A value of nil means to use the shortest notation\n\
1924 that represents the number without losing information.");
1925 Vfloat_output_format = Qnil;
1926 Qfloat_output_format = intern ("float-output-format");
1927 staticpro (&Qfloat_output_format);
1929 DEFVAR_LISP ("print-length", &Vprint_length,
1930 "Maximum length of list to print before abbreviating.\n\
1931 A value of nil means no limit.");
1932 Vprint_length = Qnil;
1934 DEFVAR_LISP ("print-level", &Vprint_level,
1935 "Maximum depth of list nesting to print before abbreviating.\n\
1936 A value of nil means no limit.");
1937 Vprint_level = Qnil;
1939 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines,
1940 "Non-nil means print newlines in strings as backslash-n.\n\
1941 Also print formfeeds as backslash-f.");
1942 print_escape_newlines = 0;
1944 DEFVAR_BOOL ("print-escape-nonascii", &print_escape_nonascii,
1945 "Non-nil means print unibyte non-ASCII chars in strings as \\OOO.\n\
1946 \(OOO is the octal representation of the character code.)\n\
1947 Only single-byte characters are affected, and only in `prin1'.");
1948 print_escape_nonascii = 0;
1950 DEFVAR_BOOL ("print-escape-multibyte", &print_escape_multibyte,
1951 "Non-nil means print multibyte characters in strings as \\xXXXX.\n\
1952 \(XXX is the hex representation of the character code.)\n\
1953 This affects only `prin1'.");
1954 print_escape_multibyte = 0;
1956 DEFVAR_BOOL ("print-quoted", &print_quoted,
1957 "Non-nil means print quoted forms with reader syntax.\n\
1958 I.e., (quote foo) prints as 'foo, (function foo) as #'foo, and, backquoted\n\
1959 forms print in the new syntax.");
1960 print_quoted = 0;
1962 DEFVAR_LISP ("print-gensym", &Vprint_gensym,
1963 "Non-nil means print uninterned symbols so they will read as uninterned.\n\
1964 I.e., the value of (make-symbol \"foobar\") prints as #:foobar.\n\
1965 When the uninterned symbol appears within a recursive data structure\n\
1966 and the symbol appears more than once, in addition use the #N# and #N=\n\
1967 constructs as needed, so that multiple references to the same symbol are\n\
1968 shared once again when the text is read back.");
1969 Vprint_gensym = Qnil;
1971 DEFVAR_LISP ("print-circle", &Vprint_circle,
1972 "*Non-nil means print recursive structures using #N= and #N# syntax.\n\
1973 If nil, printing proceeds recursively and may lead to\n\
1974 `max-lisp-eval-depth' being exceeded or an error may occur:\n\
1975 \"Apparently circular structure being printed.\" Also see\n\
1976 `print-length' and `print-level'.\n\
1977 If non-nil, shared substructures anywhere in the structure are printed\n\
1978 with `#N=' before the first occurrence (in the order of the print\n\
1979 representation) and `#N#' in place of each subsequent occurrence,\n\
1980 where N is a positive decimal integer.");
1981 Vprint_circle = Qnil;
1983 DEFVAR_LISP ("print-continuous-numbering", &Vprint_continuous_numbering,
1984 "*Non-nil means keep numbering between several print functions.\n\
1985 See `print-gensym' nad `print-circle'. See also `print-number-table'.");
1986 Vprint_continuous_numbering = Qnil;
1988 DEFVAR_LISP ("print-number-table", &Vprint_number_table,
1989 "A vector keeping the information of the current printed object.\n\
1990 This variable shouldn't be modified in Lisp level, but should be binded\n\
1991 with nil using let at the same position with `print-continuous-numbering',\n\
1992 so that the value of this variable can be freed after printing.");
1993 Vprint_number_table = Qnil;
1995 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
1996 staticpro (&Vprin1_to_string_buffer);
1998 defsubr (&Sprin1);
1999 defsubr (&Sprin1_to_string);
2000 defsubr (&Serror_message_string);
2001 defsubr (&Sprinc);
2002 defsubr (&Sprint);
2003 defsubr (&Sterpri);
2004 defsubr (&Swrite_char);
2005 defsubr (&Sexternal_debugging_output);
2007 Qexternal_debugging_output = intern ("external-debugging-output");
2008 staticpro (&Qexternal_debugging_output);
2010 Qprint_escape_newlines = intern ("print-escape-newlines");
2011 staticpro (&Qprint_escape_newlines);
2013 Qprint_escape_multibyte = intern ("print-escape-multibyte");
2014 staticpro (&Qprint_escape_multibyte);
2016 Qprint_escape_nonascii = intern ("print-escape-nonascii");
2017 staticpro (&Qprint_escape_nonascii);
2019 defsubr (&Swith_output_to_temp_buffer);