1 /* Lisp object printing and output streams.
2 Copyright (C) 1985, 86, 88, 93, 94, 95 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
31 #include "dispextern.h"
34 #endif /* not standalone */
36 #ifdef USE_TEXT_PROPERTIES
37 #include "intervals.h"
40 Lisp_Object Vstandard_output
, Qstandard_output
;
42 #ifdef LISP_FLOAT_TYPE
43 Lisp_Object Vfloat_output_format
, Qfloat_output_format
;
44 #endif /* LISP_FLOAT_TYPE */
46 /* Avoid actual stack overflow in print. */
49 /* Detect most circularities to print finite output. */
50 #define PRINT_CIRCLE 200
51 Lisp_Object being_printed
[PRINT_CIRCLE
];
53 /* When printing into a buffer, first we put the text in this
54 block, then insert it all at once. */
57 /* Size allocated in print_buffer. */
58 int print_buffer_size
;
59 /* Size used in print_buffer. */
62 /* Maximum length of list to print in full; noninteger means
63 effectively infinity */
65 Lisp_Object Vprint_length
;
67 /* Maximum depth of list to print in full; noninteger means
68 effectively infinity. */
70 Lisp_Object Vprint_level
;
72 /* Nonzero means print newlines in strings as \n. */
74 int print_escape_newlines
;
76 Lisp_Object Qprint_escape_newlines
;
78 /* Nonzero means print newline to stdout before next minibuffer message.
81 extern int noninteractive_need_newline
;
83 #ifdef MAX_PRINT_CHARS
84 static int print_chars
;
86 #endif /* MAX_PRINT_CHARS */
88 void print_interval ();
91 /* Convert between chars and GLYPHs */
95 register GLYPH
*glyphs
;
105 str_to_glyph_cpy (str
, glyphs
)
109 register GLYPH
*gp
= glyphs
;
110 register char *cp
= str
;
117 str_to_glyph_ncpy (str
, glyphs
, n
)
122 register GLYPH
*gp
= glyphs
;
123 register char *cp
= str
;
130 glyph_to_str_cpy (glyphs
, str
)
134 register GLYPH
*gp
= glyphs
;
135 register char *cp
= str
;
138 *str
++ = *gp
++ & 0377;
142 /* Low level output routines for characters and strings */
144 /* Lisp functions to do output using a stream
145 must have the stream in a variable called printcharfun
146 and must start with PRINTPREPARE and end with PRINTFINISH.
147 Use PRINTCHAR to output one character,
148 or call strout to output a block of characters.
149 Also, each one must have the declarations
150 struct buffer *old = current_buffer;
151 int old_point = -1, start_point;
152 Lisp_Object original;
155 #define PRINTPREPARE \
156 original = printcharfun; \
157 if (NILP (printcharfun)) printcharfun = Qt; \
158 if (BUFFERP (printcharfun)) \
159 { if (XBUFFER (printcharfun) != current_buffer) \
160 Fset_buffer (printcharfun); \
161 printcharfun = Qnil;} \
162 if (MARKERP (printcharfun)) \
163 { if (!(XMARKER (original)->buffer)) \
164 error ("Marker does not point anywhere"); \
165 if (XMARKER (original)->buffer != current_buffer) \
166 set_buffer_internal (XMARKER (original)->buffer); \
168 SET_PT (marker_position (printcharfun)); \
169 start_point = point; \
170 printcharfun = Qnil;} \
171 if (NILP (printcharfun)) \
173 print_buffer_pos = 0; \
174 print_buffer_size = 1000; \
175 print_buffer = (char *) xmalloc (print_buffer_size); \
180 #define PRINTFINISH \
181 if (NILP (printcharfun)) \
182 insert (print_buffer, print_buffer_pos); \
183 if (print_buffer) free (print_buffer); \
184 if (MARKERP (original)) \
185 Fset_marker (original, make_number (point), Qnil); \
186 if (old_point >= 0) \
187 SET_PT (old_point + (old_point >= start_point \
188 ? point - start_point : 0)); \
189 if (old != current_buffer) \
190 set_buffer_internal (old)
192 #define PRINTCHAR(ch) printchar (ch, printcharfun)
194 /* Index of first unused element of FRAME_MESSAGE_BUF(mini_frame). */
195 static int printbufidx
;
204 #ifdef MAX_PRINT_CHARS
207 #endif /* MAX_PRINT_CHARS */
212 if (print_buffer_pos
== print_buffer_size
)
213 print_buffer
= (char *) xrealloc (print_buffer
,
214 print_buffer_size
*= 2);
215 print_buffer
[print_buffer_pos
++] = ch
;
222 = XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window
)));
227 noninteractive_need_newline
= 1;
231 if (echo_area_glyphs
!= FRAME_MESSAGE_BUF (mini_frame
)
232 || !message_buf_print
)
234 message_log_maybe_newline ();
235 echo_area_glyphs
= FRAME_MESSAGE_BUF (mini_frame
);
237 echo_area_glyphs_length
= 0;
238 message_buf_print
= 1;
241 message_dolog (&ch
, 1, 0);
242 if (printbufidx
< FRAME_WIDTH (mini_frame
) - 1)
243 FRAME_MESSAGE_BUF (mini_frame
)[printbufidx
++] = ch
;
244 FRAME_MESSAGE_BUF (mini_frame
)[printbufidx
] = 0;
245 echo_area_glyphs_length
= printbufidx
;
249 #endif /* not standalone */
251 XSETFASTINT (ch1
, ch
);
256 strout (ptr
, size
, printcharfun
)
259 Lisp_Object printcharfun
;
263 if (EQ (printcharfun
, Qnil
))
268 if (print_buffer_pos
+ size
> print_buffer_size
)
270 print_buffer_size
= print_buffer_size
* 2 + size
;
271 print_buffer
= (char *) xrealloc (print_buffer
,
274 bcopy (ptr
, print_buffer
+ print_buffer_pos
, size
);
275 print_buffer_pos
+= size
;
277 #ifdef MAX_PRINT_CHARS
280 #endif /* MAX_PRINT_CHARS */
283 if (EQ (printcharfun
, Qt
))
286 = XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window
)));
288 i
= size
>= 0 ? size
: strlen (ptr
);
289 #ifdef MAX_PRINT_CHARS
292 #endif /* MAX_PRINT_CHARS */
296 fwrite (ptr
, 1, i
, stdout
);
297 noninteractive_need_newline
= 1;
301 if (echo_area_glyphs
!= FRAME_MESSAGE_BUF (mini_frame
)
302 || !message_buf_print
)
304 message_log_maybe_newline ();
305 echo_area_glyphs
= FRAME_MESSAGE_BUF (mini_frame
);
307 echo_area_glyphs_length
= 0;
308 message_buf_print
= 1;
311 message_dolog (ptr
, i
, 0);
312 if (i
> FRAME_WIDTH (mini_frame
) - printbufidx
- 1)
313 i
= FRAME_WIDTH (mini_frame
) - printbufidx
- 1;
314 bcopy (ptr
, &FRAME_MESSAGE_BUF (mini_frame
) [printbufidx
], i
);
316 echo_area_glyphs_length
= printbufidx
;
317 FRAME_MESSAGE_BUF (mini_frame
) [printbufidx
] = 0;
324 PRINTCHAR (ptr
[i
++]);
327 PRINTCHAR (ptr
[i
++]);
330 /* Print the contents of a string STRING using PRINTCHARFUN.
331 It isn't safe to use strout in many cases,
332 because printing one char can relocate. */
334 print_string (string
, printcharfun
)
336 Lisp_Object printcharfun
;
338 if (EQ (printcharfun
, Qt
) || NILP (printcharfun
))
339 /* strout is safe for output to a frame (echo area) or to print_buffer. */
340 strout (XSTRING (string
)->data
, XSTRING (string
)->size
, printcharfun
);
343 /* Otherwise, fetch the string address for each character. */
345 int size
= XSTRING (string
)->size
;
348 for (i
= 0; i
< size
; i
++)
349 PRINTCHAR (XSTRING (string
)->data
[i
]);
354 DEFUN ("write-char", Fwrite_char
, Swrite_char
, 1, 2, 0,
355 "Output character CHARACTER to stream PRINTCHARFUN.\n\
356 PRINTCHARFUN defaults to the value of `standard-output' (which see).")
357 (character
, printcharfun
)
358 Lisp_Object character
, printcharfun
;
360 struct buffer
*old
= current_buffer
;
363 Lisp_Object original
;
365 if (NILP (printcharfun
))
366 printcharfun
= Vstandard_output
;
367 CHECK_NUMBER (character
, 0);
369 PRINTCHAR (XINT (character
));
374 /* Used from outside of print.c to print a block of SIZE chars at DATA
375 on the default output stream.
376 Do not use this on the contents of a Lisp string. */
378 write_string (data
, size
)
382 struct buffer
*old
= current_buffer
;
383 Lisp_Object printcharfun
;
386 Lisp_Object original
;
388 printcharfun
= Vstandard_output
;
391 strout (data
, size
, printcharfun
);
395 /* Used from outside of print.c to print a block of SIZE chars at DATA
396 on a specified stream PRINTCHARFUN.
397 Do not use this on the contents of a Lisp string. */
399 write_string_1 (data
, size
, printcharfun
)
402 Lisp_Object printcharfun
;
404 struct buffer
*old
= current_buffer
;
407 Lisp_Object original
;
410 strout (data
, size
, printcharfun
);
418 temp_output_buffer_setup (bufname
)
421 register struct buffer
*old
= current_buffer
;
422 register Lisp_Object buf
;
424 Fset_buffer (Fget_buffer_create (build_string (bufname
)));
426 current_buffer
->directory
= old
->directory
;
427 current_buffer
->read_only
= Qnil
;
430 XSETBUFFER (buf
, current_buffer
);
431 specbind (Qstandard_output
, buf
);
433 set_buffer_internal (old
);
437 internal_with_output_to_temp_buffer (bufname
, function
, args
)
439 Lisp_Object (*function
) ();
442 int count
= specpdl_ptr
- specpdl
;
443 Lisp_Object buf
, val
;
447 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
448 temp_output_buffer_setup (bufname
);
449 buf
= Vstandard_output
;
452 val
= (*function
) (args
);
455 temp_output_buffer_show (buf
);
458 return unbind_to (count
, val
);
461 DEFUN ("with-output-to-temp-buffer", Fwith_output_to_temp_buffer
, Swith_output_to_temp_buffer
,
463 "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.\n\
464 The buffer is cleared out initially, and marked as unmodified when done.\n\
465 All output done by BODY is inserted in that buffer by default.\n\
466 The buffer is displayed in another window, but not selected.\n\
467 The value of the last form in BODY is returned.\n\
468 If BODY does not finish normally, the buffer BUFNAME is not displayed.\n\n\
469 If variable `temp-buffer-show-function' is non-nil, call it at the end\n\
470 to get the buffer displayed. It gets one argument, the buffer to display.")
476 int count
= specpdl_ptr
- specpdl
;
477 Lisp_Object buf
, val
;
480 name
= Feval (Fcar (args
));
483 CHECK_STRING (name
, 0);
484 temp_output_buffer_setup (XSTRING (name
)->data
);
485 buf
= Vstandard_output
;
487 val
= Fprogn (Fcdr (args
));
489 temp_output_buffer_show (buf
);
491 return unbind_to (count
, val
);
493 #endif /* not standalone */
495 static void print ();
497 DEFUN ("terpri", Fterpri
, Sterpri
, 0, 1, 0,
498 "Output a newline to stream PRINTCHARFUN.\n\
499 If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used.")
501 Lisp_Object printcharfun
;
503 struct buffer
*old
= current_buffer
;
506 Lisp_Object original
;
508 if (NILP (printcharfun
))
509 printcharfun
= Vstandard_output
;
516 DEFUN ("prin1", Fprin1
, Sprin1
, 1, 2, 0,
517 "Output the printed representation of OBJECT, any Lisp object.\n\
518 Quoting characters are printed when needed to make output that `read'\n\
519 can handle, whenever this is possible.\n\
520 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
521 (object
, printcharfun
)
522 Lisp_Object object
, printcharfun
;
524 struct buffer
*old
= current_buffer
;
527 Lisp_Object original
;
529 #ifdef MAX_PRINT_CHARS
531 #endif /* MAX_PRINT_CHARS */
532 if (NILP (printcharfun
))
533 printcharfun
= Vstandard_output
;
536 print (object
, printcharfun
, 1);
541 /* a buffer which is used to hold output being built by prin1-to-string */
542 Lisp_Object Vprin1_to_string_buffer
;
544 DEFUN ("prin1-to-string", Fprin1_to_string
, Sprin1_to_string
, 1, 2, 0,
545 "Return a string containing the printed representation of OBJECT,\n\
546 any Lisp object. Quoting characters are used when needed to make output\n\
547 that `read' can handle, whenever this is possible, unless the optional\n\
548 second argument NOESCAPE is non-nil.")
550 Lisp_Object object
, noescape
;
552 struct buffer
*old
= current_buffer
;
555 Lisp_Object original
, printcharfun
;
556 struct gcpro gcpro1
, gcpro2
;
559 /* Save and restore this--we are altering a buffer
560 but we don't want to deactivate the mark just for that.
561 No need for specbind, since errors deactivate the mark. */
562 tem
= Vdeactivate_mark
;
563 GCPRO2 (object
, tem
);
565 printcharfun
= Vprin1_to_string_buffer
;
568 print (object
, printcharfun
, NILP (noescape
));
569 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
571 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
572 object
= Fbuffer_string ();
575 set_buffer_internal (old
);
577 Vdeactivate_mark
= tem
;
583 DEFUN ("princ", Fprinc
, Sprinc
, 1, 2, 0,
584 "Output the printed representation of OBJECT, any Lisp object.\n\
585 No quoting characters are used; no delimiters are printed around\n\
586 the contents of strings.\n\
587 Output stream is PRINTCHARFUN, or value of standard-output (which see).")
588 (object
, printcharfun
)
589 Lisp_Object object
, printcharfun
;
591 struct buffer
*old
= current_buffer
;
594 Lisp_Object original
;
596 if (NILP (printcharfun
))
597 printcharfun
= Vstandard_output
;
600 print (object
, printcharfun
, 0);
605 DEFUN ("print", Fprint
, Sprint
, 1, 2, 0,
606 "Output the printed representation of OBJECT, with newlines around it.\n\
607 Quoting characters are printed when needed to make output that `read'\n\
608 can handle, whenever this is possible.\n\
609 Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
610 (object
, printcharfun
)
611 Lisp_Object object
, printcharfun
;
613 struct buffer
*old
= current_buffer
;
616 Lisp_Object original
;
619 #ifdef MAX_PRINT_CHARS
621 max_print
= MAX_PRINT_CHARS
;
622 #endif /* MAX_PRINT_CHARS */
623 if (NILP (printcharfun
))
624 printcharfun
= Vstandard_output
;
629 print (object
, printcharfun
, 1);
632 #ifdef MAX_PRINT_CHARS
635 #endif /* MAX_PRINT_CHARS */
640 /* The subroutine object for external-debugging-output is kept here
641 for the convenience of the debugger. */
642 Lisp_Object Qexternal_debugging_output
;
644 DEFUN ("external-debugging-output", Fexternal_debugging_output
, Sexternal_debugging_output
, 1, 1, 0,
645 "Write CHARACTER to stderr.\n\
646 You can call print while debugging emacs, and pass it this function\n\
647 to make it write to the debugging output.\n")
649 Lisp_Object character
;
651 CHECK_NUMBER (character
, 0);
652 putc (XINT (character
), stderr
);
657 /* This is the interface for debugging printing. */
663 Fprin1 (arg
, Qexternal_debugging_output
);
664 fprintf (stderr
, "\r\n");
667 DEFUN ("error-message-string", Ferror_message_string
, Serror_message_string
,
669 "Convert an error value (ERROR-SYMBOL . DATA) to an error message.")
673 struct buffer
*old
= current_buffer
;
674 Lisp_Object original
, printcharfun
, value
;
677 print_error_message (obj
, Vprin1_to_string_buffer
, NULL
);
679 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer
));
680 value
= Fbuffer_string ();
684 set_buffer_internal (old
);
690 /* Print an error message for the error DATA
691 onto Lisp output stream STREAM (suitable for the print functions). */
693 print_error_message (data
, stream
)
694 Lisp_Object data
, stream
;
696 Lisp_Object errname
, errmsg
, file_error
, tail
;
700 errname
= Fcar (data
);
702 if (EQ (errname
, Qerror
))
705 if (!CONSP (data
)) data
= Qnil
;
706 errmsg
= Fcar (data
);
711 errmsg
= Fget (errname
, Qerror_message
);
712 file_error
= Fmemq (Qfile_error
,
713 Fget (errname
, Qerror_conditions
));
716 /* Print an error message including the data items. */
718 tail
= Fcdr_safe (data
);
721 /* For file-error, make error message by concatenating
722 all the data items. They are all strings. */
723 if (!NILP (file_error
) && !NILP (tail
))
724 errmsg
= XCONS (tail
)->car
, tail
= XCONS (tail
)->cdr
;
726 if (STRINGP (errmsg
))
727 Fprinc (errmsg
, stream
);
729 write_string_1 ("peculiar error", -1, stream
);
731 for (i
= 0; CONSP (tail
); tail
= Fcdr (tail
), i
++)
733 write_string_1 (i
? ", " : ": ", 2, stream
);
734 if (!NILP (file_error
))
735 Fprinc (Fcar (tail
), stream
);
737 Fprin1 (Fcar (tail
), stream
);
742 #ifdef LISP_FLOAT_TYPE
745 * The buffer should be at least as large as the max string size of the
746 * largest float, printed in the biggest notation. This is undoubtedly
747 * 20d float_output_format, with the negative of the C-constant "HUGE"
750 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
752 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
753 * case of -1e307 in 20d float_output_format. What is one to do (short of
754 * re-writing _doprnt to be more sane)?
759 float_to_string (buf
, data
)
766 if (NILP (Vfloat_output_format
)
767 || !STRINGP (Vfloat_output_format
))
770 sprintf (buf
, "%.17g", data
);
775 /* Check that the spec we have is fully valid.
776 This means not only valid for printf,
777 but meant for floats, and reasonable. */
778 cp
= XSTRING (Vfloat_output_format
)->data
;
787 /* Check the width specification. */
789 if ('0' <= *cp
&& *cp
<= '9')
793 width
= (width
* 10) + (*cp
++ - '0');
794 while (*cp
>= '0' && *cp
<= '9');
796 /* A precision of zero is valid only for %f. */
798 || (width
== 0 && *cp
!= 'f'))
802 if (*cp
!= 'e' && *cp
!= 'f' && *cp
!= 'g')
808 sprintf (buf
, XSTRING (Vfloat_output_format
)->data
, data
);
811 /* Make sure there is a decimal point with digit after, or an
812 exponent, so that the value is readable as a float. But don't do
813 this with "%.0f"; it's valid for that not to produce a decimal
814 point. Note that width can be 0 only for %.0f. */
817 for (cp
= buf
; *cp
; cp
++)
818 if ((*cp
< '0' || *cp
> '9') && *cp
!= '-')
821 if (*cp
== '.' && cp
[1] == 0)
835 #endif /* LISP_FLOAT_TYPE */
838 print (obj
, printcharfun
, escapeflag
)
840 register Lisp_Object printcharfun
;
847 #if 1 /* I'm not sure this is really worth doing. */
848 /* Detect circularities and truncate them.
849 No need to offer any alternative--this is better than an error. */
850 if (CONSP (obj
) || VECTORP (obj
) || COMPILEDP (obj
))
853 for (i
= 0; i
< print_depth
; i
++)
854 if (EQ (obj
, being_printed
[i
]))
856 sprintf (buf
, "#%d", i
);
857 strout (buf
, -1, printcharfun
);
863 being_printed
[print_depth
] = obj
;
866 if (print_depth
> PRINT_CIRCLE
)
867 error ("Apparently circular structure being printed");
868 #ifdef MAX_PRINT_CHARS
869 if (max_print
&& print_chars
> max_print
)
874 #endif /* MAX_PRINT_CHARS */
876 switch (XGCTYPE (obj
))
879 if (sizeof (int) == sizeof (EMACS_INT
))
880 sprintf (buf
, "%d", XINT (obj
));
881 else if (sizeof (long) == sizeof (EMACS_INT
))
882 sprintf (buf
, "%ld", XINT (obj
));
885 strout (buf
, -1, printcharfun
);
888 #ifdef LISP_FLOAT_TYPE
891 char pigbuf
[350]; /* see comments in float_to_string */
893 float_to_string (pigbuf
, XFLOAT(obj
)->data
);
894 strout (pigbuf
, -1, printcharfun
);
901 print_string (obj
, printcharfun
);
905 register unsigned char c
;
910 #ifdef USE_TEXT_PROPERTIES
911 if (!NULL_INTERVAL_P (XSTRING (obj
)->intervals
))
919 for (i
= 0; i
< XSTRING (obj
)->size
; i
++)
922 c
= XSTRING (obj
)->data
[i
];
923 if (c
== '\n' && print_escape_newlines
)
928 else if (c
== '\f' && print_escape_newlines
)
935 if (c
== '\"' || c
== '\\')
942 #ifdef USE_TEXT_PROPERTIES
943 if (!NULL_INTERVAL_P (XSTRING (obj
)->intervals
))
945 traverse_intervals (XSTRING (obj
)->intervals
,
946 0, 0, print_interval
, printcharfun
);
957 register int confusing
;
958 register unsigned char *p
= XSYMBOL (obj
)->name
->data
;
959 register unsigned char *end
= p
+ XSYMBOL (obj
)->name
->size
;
960 register unsigned char c
;
962 if (p
!= end
&& (*p
== '-' || *p
== '+')) p
++;
967 while (p
!= end
&& *p
>= '0' && *p
<= '9')
969 confusing
= (end
== p
);
972 p
= XSYMBOL (obj
)->name
->data
;
979 if (c
== '\"' || c
== '\\' || c
== '\'' || c
== ';' || c
== '#' ||
980 c
== '(' || c
== ')' || c
== ',' || c
=='.' || c
== '`' ||
981 c
== '[' || c
== ']' || c
== '?' || c
<= 040 || confusing
)
982 PRINTCHAR ('\\'), confusing
= 0;
990 /* If deeper than spec'd depth, print placeholder. */
991 if (INTEGERP (Vprint_level
)
992 && print_depth
> XINT (Vprint_level
))
993 strout ("...", -1, printcharfun
);
999 register int max
= 0;
1001 if (INTEGERP (Vprint_length
))
1002 max
= XINT (Vprint_length
);
1003 /* Could recognize circularities in cdrs here,
1004 but that would make printing of long lists quadratic.
1005 It's not worth doing. */
1012 strout ("...", 3, printcharfun
);
1015 print (Fcar (obj
), printcharfun
, escapeflag
);
1019 if (!NILP (obj
) && !CONSP (obj
))
1021 strout (" . ", 3, printcharfun
);
1022 print (obj
, printcharfun
, escapeflag
);
1028 case Lisp_Vectorlike
:
1033 strout ("#<process ", -1, printcharfun
);
1034 print_string (XPROCESS (obj
)->name
, printcharfun
);
1038 print_string (XPROCESS (obj
)->name
, printcharfun
);
1040 else if (BOOL_VECTOR_P (obj
))
1043 register unsigned char c
;
1044 struct gcpro gcpro1
;
1046 = (XBOOL_VECTOR (obj
)->size
+ BITS_PER_CHAR
) / BITS_PER_CHAR
;
1052 sprintf (buf
, "%d", XBOOL_VECTOR (obj
)->size
);
1053 strout (buf
, -1, printcharfun
);
1056 /* Don't print more characters than the specified maximum. */
1057 if (INTEGERP (Vprint_length
)
1058 && XINT (Vprint_length
) < size_in_chars
)
1059 size_in_chars
= XINT (Vprint_length
);
1061 for (i
= 0; i
< size_in_chars
; i
++)
1064 c
= XBOOL_VECTOR (obj
)->data
[i
];
1065 if (c
== '\n' && print_escape_newlines
)
1070 else if (c
== '\f' && print_escape_newlines
)
1077 if (c
== '\"' || c
== '\\')
1086 else if (SUBRP (obj
))
1088 strout ("#<subr ", -1, printcharfun
);
1089 strout (XSUBR (obj
)->symbol_name
, -1, printcharfun
);
1093 else if (WINDOWP (obj
))
1095 strout ("#<window ", -1, printcharfun
);
1096 sprintf (buf
, "%d", XFASTINT (XWINDOW (obj
)->sequence_number
));
1097 strout (buf
, -1, printcharfun
);
1098 if (!NILP (XWINDOW (obj
)->buffer
))
1100 strout (" on ", -1, printcharfun
);
1101 print_string (XBUFFER (XWINDOW (obj
)->buffer
)->name
, printcharfun
);
1105 else if (BUFFERP (obj
))
1107 if (NILP (XBUFFER (obj
)->name
))
1108 strout ("#<killed buffer>", -1, printcharfun
);
1109 else if (escapeflag
)
1111 strout ("#<buffer ", -1, printcharfun
);
1112 print_string (XBUFFER (obj
)->name
, printcharfun
);
1116 print_string (XBUFFER (obj
)->name
, printcharfun
);
1118 else if (WINDOW_CONFIGURATIONP (obj
))
1120 strout ("#<window-configuration>", -1, printcharfun
);
1123 else if (FRAMEP (obj
))
1125 strout ((FRAME_LIVE_P (XFRAME (obj
))
1126 ? "#<frame " : "#<dead frame "),
1128 print_string (XFRAME (obj
)->name
, printcharfun
);
1129 sprintf (buf
, " 0x%lx", (unsigned long) (XFRAME (obj
)));
1130 strout (buf
, -1, printcharfun
);
1134 #endif /* not standalone */
1137 int size
= XVECTOR (obj
)->size
;
1138 if (COMPILEDP (obj
))
1141 size
&= PSEUDOVECTOR_SIZE_MASK
;
1143 if (CHAR_TABLE_P (obj
))
1145 /* We print a char-table as if it were a vector,
1146 lumping the parent and default slots in with the
1147 character slots. But we add #^ as a prefix. */
1150 size
&= PSEUDOVECTOR_SIZE_MASK
;
1152 if (size
& PSEUDOVECTOR_FLAG
)
1158 register Lisp_Object tem
;
1160 /* Don't print more elements than the specified maximum. */
1161 if (INTEGERP (Vprint_length
)
1162 && XINT (Vprint_length
) < size
)
1163 size
= XINT (Vprint_length
);
1165 for (i
= 0; i
< size
; i
++)
1167 if (i
) PRINTCHAR (' ');
1168 tem
= XVECTOR (obj
)->contents
[i
];
1169 print (tem
, printcharfun
, escapeflag
);
1178 switch (XMISCTYPE (obj
))
1180 case Lisp_Misc_Marker
:
1181 strout ("#<marker ", -1, printcharfun
);
1182 if (!(XMARKER (obj
)->buffer
))
1183 strout ("in no buffer", -1, printcharfun
);
1186 sprintf (buf
, "at %d", marker_position (obj
));
1187 strout (buf
, -1, printcharfun
);
1188 strout (" in ", -1, printcharfun
);
1189 print_string (XMARKER (obj
)->buffer
->name
, printcharfun
);
1194 case Lisp_Misc_Overlay
:
1195 strout ("#<overlay ", -1, printcharfun
);
1196 if (!(XMARKER (OVERLAY_START (obj
))->buffer
))
1197 strout ("in no buffer", -1, printcharfun
);
1200 sprintf (buf
, "from %d to %d in ",
1201 marker_position (OVERLAY_START (obj
)),
1202 marker_position (OVERLAY_END (obj
)));
1203 strout (buf
, -1, printcharfun
);
1204 print_string (XMARKER (OVERLAY_START (obj
))->buffer
->name
,
1210 /* Remaining cases shouldn't happen in normal usage, but let's print
1211 them anyway for the benefit of the debugger. */
1212 case Lisp_Misc_Free
:
1213 strout ("#<misc free cell>", -1, printcharfun
);
1216 case Lisp_Misc_Intfwd
:
1217 sprintf (buf
, "#<intfwd to %d>", *XINTFWD (obj
)->intvar
);
1218 strout (buf
, -1, printcharfun
);
1221 case Lisp_Misc_Boolfwd
:
1222 sprintf (buf
, "#<boolfwd to %s>",
1223 (*XBOOLFWD (obj
)->boolvar
? "t" : "nil"));
1224 strout (buf
, -1, printcharfun
);
1227 case Lisp_Misc_Objfwd
:
1228 strout ("#<objfwd to ", -1, printcharfun
);
1229 print (*XOBJFWD (obj
)->objvar
, printcharfun
, escapeflag
);
1233 case Lisp_Misc_Buffer_Objfwd
:
1234 strout ("#<buffer_objfwd to ", -1, printcharfun
);
1235 print (*(Lisp_Object
*)((char *)current_buffer
1236 + XBUFFER_OBJFWD (obj
)->offset
),
1237 printcharfun
, escapeflag
);
1241 case Lisp_Misc_Kboard_Objfwd
:
1242 strout ("#<kboard_objfwd to ", -1, printcharfun
);
1243 print (*(Lisp_Object
*)((char *) current_kboard
1244 + XKBOARD_OBJFWD (obj
)->offset
),
1245 printcharfun
, escapeflag
);
1249 case Lisp_Misc_Buffer_Local_Value
:
1250 strout ("#<buffer_local_value ", -1, printcharfun
);
1251 goto do_buffer_local
;
1252 case Lisp_Misc_Some_Buffer_Local_Value
:
1253 strout ("#<some_buffer_local_value ", -1, printcharfun
);
1255 strout ("[realvalue] ", -1, printcharfun
);
1256 print (XBUFFER_LOCAL_VALUE (obj
)->car
, printcharfun
, escapeflag
);
1257 strout ("[buffer] ", -1, printcharfun
);
1258 print (XCONS (XBUFFER_LOCAL_VALUE (obj
)->cdr
)->car
,
1259 printcharfun
, escapeflag
);
1260 strout ("[alist-elt] ", -1, printcharfun
);
1261 print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj
)->cdr
)->cdr
)->car
,
1262 printcharfun
, escapeflag
);
1263 strout ("[default-value] ", -1, printcharfun
);
1264 print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj
)->cdr
)->cdr
)->cdr
,
1265 printcharfun
, escapeflag
);
1273 #endif /* standalone */
1278 /* We're in trouble if this happens!
1279 Probably should just abort () */
1280 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, printcharfun
);
1282 sprintf (buf
, "(MISC 0x%04x)", (int) XMISCTYPE (obj
));
1283 else if (VECTORLIKEP (obj
))
1284 sprintf (buf
, "(PVEC 0x%08x)", (int) XVECTOR (obj
)->size
);
1286 sprintf (buf
, "(0x%02x)", (int) XTYPE (obj
));
1287 strout (buf
, -1, printcharfun
);
1288 strout (" Save your buffers immediately and please report this bug>",
1296 #ifdef USE_TEXT_PROPERTIES
1298 /* Print a description of INTERVAL using PRINTCHARFUN.
1299 This is part of printing a string that has text properties. */
1302 print_interval (interval
, printcharfun
)
1304 Lisp_Object printcharfun
;
1307 print (make_number (interval
->position
), printcharfun
, 1);
1309 print (make_number (interval
->position
+ LENGTH (interval
)),
1312 print (interval
->plist
, printcharfun
, 1);
1315 #endif /* USE_TEXT_PROPERTIES */
1320 staticpro (&Qprint_escape_newlines
);
1321 Qprint_escape_newlines
= intern ("print-escape-newlines");
1323 DEFVAR_LISP ("standard-output", &Vstandard_output
,
1324 "Output stream `print' uses by default for outputting a character.\n\
1325 This may be any function of one argument.\n\
1326 It may also be a buffer (output is inserted before point)\n\
1327 or a marker (output is inserted and the marker is advanced)\n\
1328 or the symbol t (output appears in the echo area).");
1329 Vstandard_output
= Qt
;
1330 Qstandard_output
= intern ("standard-output");
1331 staticpro (&Qstandard_output
);
1333 #ifdef LISP_FLOAT_TYPE
1334 DEFVAR_LISP ("float-output-format", &Vfloat_output_format
,
1335 "The format descriptor string used to print floats.\n\
1336 This is a %-spec like those accepted by `printf' in C,\n\
1337 but with some restrictions. It must start with the two characters `%.'.\n\
1338 After that comes an integer precision specification,\n\
1339 and then a letter which controls the format.\n\
1340 The letters allowed are `e', `f' and `g'.\n\
1341 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"\n\
1342 Use `f' for decimal point notation \"DIGITS.DIGITS\".\n\
1343 Use `g' to choose the shorter of those two formats for the number at hand.\n\
1344 The precision in any of these cases is the number of digits following\n\
1345 the decimal point. With `f', a precision of 0 means to omit the\n\
1346 decimal point. 0 is not allowed with `e' or `g'.\n\n\
1347 A value of nil means to use `%.17g'.");
1348 Vfloat_output_format
= Qnil
;
1349 Qfloat_output_format
= intern ("float-output-format");
1350 staticpro (&Qfloat_output_format
);
1351 #endif /* LISP_FLOAT_TYPE */
1353 DEFVAR_LISP ("print-length", &Vprint_length
,
1354 "Maximum length of list to print before abbreviating.\n\
1355 A value of nil means no limit.");
1356 Vprint_length
= Qnil
;
1358 DEFVAR_LISP ("print-level", &Vprint_level
,
1359 "Maximum depth of list nesting to print before abbreviating.\n\
1360 A value of nil means no limit.");
1361 Vprint_level
= Qnil
;
1363 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines
,
1364 "Non-nil means print newlines in strings as backslash-n.\n\
1365 Also print formfeeds as backslash-f.");
1366 print_escape_newlines
= 0;
1368 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
1369 staticpro (&Vprin1_to_string_buffer
);
1372 defsubr (&Sprin1_to_string
);
1373 defsubr (&Serror_message_string
);
1377 defsubr (&Swrite_char
);
1378 defsubr (&Sexternal_debugging_output
);
1380 Qexternal_debugging_output
= intern ("external-debugging-output");
1381 staticpro (&Qexternal_debugging_output
);
1384 defsubr (&Swith_output_to_temp_buffer
);
1385 #endif /* not standalone */