1 /* Lisp object printing and output streams.
2 Copyright (C) 1985, 1986, 1988, 1992-1995 Free Software Foundation, Inc.
3 Copyright (C) 1995, 1996, 2000, 2002 Ben Wing.
5 This file is part of SXEmacs
7 SXEmacs 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 3 of the License, or
10 (at your option) any later version.
12 SXEmacs 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 this program. If not, see <http://www.gnu.org/licenses/>. */
21 /* Synched up with: Not synched with FSF. */
23 /* This file has been Mule-ized. */
25 /* Seriously hacked on by Ben Wing for Mule. */
30 #include "backtrace.h"
33 #include "ui/TTY/console-tty.h" /* for stuff in
34 write_string_to_stdio_stream. Needs
36 #include "ui/console-stream.h"
39 #include "ui/insdel.h"
44 /* Define if not in float.h */
49 Lisp_Object Vstandard_output, Qstandard_output;
51 /* The subroutine object for external-debugging-output is kept here
52 for the convenience of the debugger. */
53 Lisp_Object Qexternal_debugging_output, Qalternate_debugging_output;
55 /* Avoid actual stack overflow in print. */
56 static int print_depth;
58 /* Detect most circularities to print finite output. */
59 #define PRINT_CIRCLE 200
60 static Lisp_Object being_printed[PRINT_CIRCLE];
62 /* Maximum length of list or vector to print in full; noninteger means
63 effectively infinity */
65 Lisp_Object Vprint_length;
66 Lisp_Object Qprint_length;
68 /* Maximum length of string to print in full; noninteger means
69 effectively infinity */
71 Lisp_Object Vprint_string_length;
72 Lisp_Object Qprint_string_length;
74 /* Maximum depth of list to print in full; noninteger means
75 effectively infinity. */
77 Lisp_Object Vprint_level;
79 /* Label to use when making echo-area messages. */
81 Lisp_Object Vprint_message_label;
83 /* Nonzero means print newlines in strings as \n. */
85 int print_escape_newlines;
88 /* Non-nil means print #: before uninterned symbols.
89 Neither t nor nil means so that and don't clear Vprint_gensym_alist
90 on entry to and exit from print functions. */
91 Lisp_Object Vprint_gensym;
92 Lisp_Object Vprint_gensym_alist;
94 Lisp_Object Qdisplay_error;
95 Lisp_Object Qprint_message_label;
97 Lisp_Object Vcustom_object_printer;
99 /* Force immediate output of all printed data. Used for debugging. */
100 int print_unbuffered;
102 FILE *termscript; /* Stdio stream being used for copy of all output. */
104 int stdout_needs_newline;
106 void debug_backtrace(void);
109 std_handle_out_external(FILE * stream, Lisp_Object lstream,
110 const Extbyte * extptr, Extcount extlen,
111 /* is this really stdout/stderr?
112 (controls termscript writing) */
113 int output_is_std_handle, int must_flush)
115 assert(extptr != NULL);
118 stdout_needs_newline = 1;
122 fwrite(extptr, 1, extlen, stream);
123 if (must_flush) fflush(stream);
125 Lstream_write(XLSTREAM(lstream), extptr, extlen);
127 if (output_is_std_handle) {
129 fwrite(extptr, 1, extlen, termscript);
132 stdout_needs_newline = extptr[extlen - 1] != '\n';
137 #define SXE_VSNPRINT_VA(ret__,sbuf__,buf__,size__,spec__,tries__,type__,fmt__,args__) \
140 ret__ = vsnprintf((char*)buf__,size__,fmt__,args__); \
141 if ( ret__ == 0 ) { \
142 /* Nothing to write */ \
144 } else if ( ret__ < 0 ) { \
145 XMALLOC_UNBIND(buf__,size__,spec__); \
147 XMALLOC_OR_ALLOCA(buf__,size__,type__); \
148 } else if ( (size_t)ret__ > (size_t)size__ ) { \
149 /* We need more space, so we need to allocate it */ \
150 XMALLOC_UNBIND(buf__,size__,spec__); \
151 size__ = ret__ + 1; \
152 XMALLOC_OR_ALLOCA(buf__,size__,type__); \
155 } while( ret__ < 0 && tries__ > 0 )
158 int write_fmt_str(Lisp_Object stream, const char* fmt, ...)
162 int bufsize, retval, tries = 3;
163 /* write_fmt_str is used for small prints usually... */
165 int speccount = specpdl_depth();
169 bufsize = sizeof(buffer);
171 SXE_VSNPRINT_VA(retval,buffer,kludge,bufsize,speccount,tries,char,fmt,args);
174 write_c_string(kludge,stream);
176 XMALLOC_UNBIND(kludge, bufsize, speccount);
180 error("Error attempting to write write format string '%s'",
185 int write_fmt_string(Lisp_Object stream, const char *fmt, ...)
189 int bufsize, retval, tries = 3;
190 /* write_va is used for small prints usually... */
192 int speccount = specpdl_depth();
196 bufsize = sizeof(buffer);
198 SXE_VSNPRINT_VA(retval,buffer,kludge,bufsize,speccount,tries,char,fmt,args);
200 write_c_string(kludge,stream);
201 XMALLOC_UNBIND(kludge, bufsize, speccount);
205 error("Error attempting to write write format string '%s'",
210 /* #### The following function should be replaced a call to the
211 emacs_doprnt_*() functions. This is the only way to ensure that
212 I18N3 works properly (many implementations of the *printf()
213 functions, including the ones included in glibc, do not implement
214 the %###$ argument-positioning syntax).
216 Note, however, that to do this, we'd have to
218 1) pre-allocate all the lstreams and do whatever else was necessary
219 to make sure that no allocation occurs, since these functions may be
220 called from fatal_error_signal().
222 2) (to be really correct) make a new lstream that outputs using
223 mswindows_output_console_string(). */
225 static int std_handle_out_va(FILE * stream, const char *fmt, va_list args)
227 int retval, tries = 3;
231 Bufbyte buffer[1024]; /* Tax stack lightly, used to be 16KiB */
232 int speccount = specpdl_depth();
234 bufsize = sizeof(buffer);
237 SXE_VSNPRINT_VA(retval,buffer,kludge,bufsize,speccount,tries,Bufbyte,fmt,args);
240 /* nothing to write */
243 use_fprintf = ! initialized ||fatal_error_in_progress ||
244 inhibit_non_essential_printing_operations;
248 fprintf(stream,"%s",(char*)kludge);
250 Extbyte *extptr = NULL;
251 Extcount extlen = retval;
253 TO_EXTERNAL_FORMAT(DATA, (kludge, strlen((char *)kludge)),
254 ALLOCA, (extptr, extlen), Qnative);
255 std_handle_out_external(stream, Qnil, extptr, extlen, 1, 1);
259 fprintf(stream,"Error attempting to write format string '%s'",
262 const Extbyte *msg = "Error attempting to write format string";
263 std_handle_out_external(stream, Qnil, msg, strlen(msg), 1, 1);
266 XMALLOC_UNBIND(kludge, bufsize, speccount);
271 /* Output portably to stderr or its equivalent; call GETTEXT on the
272 format string. Automatically flush when done. */
274 int stderr_out(const char *fmt, ...)
282 && !fatal_error_in_progress ? GETTEXT(fmt) : fmt, args);
287 /* Output portably to stdout or its equivalent; call GETTEXT on the
288 format string. Automatically flush when done. */
290 int stdout_out(const char *fmt, ...)
295 retval = std_handle_out_va(stdout,
296 (initialized && !fatal_error_in_progress
297 ? GETTEXT(fmt) : fmt),
303 DOESNT_RETURN fatal(const char *fmt, ...)
308 stderr_out("\nSXEmacs: ");
309 std_handle_out_va(stderr,
310 (initialized && !fatal_error_in_progress
311 ? GETTEXT(fmt) : fmt),
319 /* Write a string (in internal format) to stdio stream STREAM. */
322 write_string_to_stdio_stream(FILE * stream, struct console *con,
324 Bytecount offset, Bytecount len,
325 Lisp_Object coding_system, int must_flush)
328 const Extbyte *extptr = NULL;
330 /* #### yuck! sometimes this function is called with string data,
331 and the following call may gc. */
333 Bufbyte *puta = (Bufbyte *) alloca(len);
334 memcpy(puta, str + offset, len);
336 if (initialized && !inhibit_non_essential_printing_operations) {
337 TO_EXTERNAL_FORMAT(DATA, (puta, len),
338 ALLOCA, (extptr, extlen),
341 if( extptr == NULL ) {
342 extptr = (Extbyte *) puta;
343 extlen = (Bytecount) len;
349 std_handle_out_external(stream, Qnil, extptr, extlen,
351 || stream == stderr, must_flush);
352 } else if(con != NULL) {
353 assert(CONSOLE_TTY_P(con));
354 std_handle_out_external(0, CONSOLE_TTY_DATA(con)->outstream,
356 CONSOLE_TTY_DATA(con)->is_stdio,
359 error("Error attempting to write write '%s' with no stream nor console", str);
365 /* Write a string to the output location specified in FUNCTION.
366 Arguments NONRELOC, RELOC, OFFSET, and LEN are as in
367 buffer_insert_string_1() in insdel.c. */
370 output_string(Lisp_Object function, const Bufbyte * nonreloc,
371 Lisp_Object reloc, Bytecount offset, Bytecount len)
373 /* This function can GC */
375 /* We change the value of nonreloc (fetching it from reloc as
376 necessary), but we don't want to pass this changed value on to
377 other functions that take both a nonreloc and a reloc, or things
378 may get confused and an assertion failure in
379 fixup_internal_substring() may get triggered. */
380 const Bufbyte *newnonreloc = nonreloc;
381 struct gcpro gcpro1, gcpro2;
383 /* Emacs won't print while GCing, but an external debugger might */
387 /* Perhaps not necessary but probably safer. */
388 GCPRO2(function, reloc);
390 fixup_internal_substring(newnonreloc, reloc, offset, &len);
393 newnonreloc = XSTRING_DATA(reloc);
395 cclen = bytecount_to_charcount(newnonreloc + offset, len);
397 if (LSTREAMP(function)) {
398 if (STRINGP(reloc)) {
399 /* Protect against Lstream_write() causing a GC and
400 relocating the string. For small strings, we do it by
401 alloc'ing the string and using a copy; for large strings,
404 Bufbyte *copied = alloca_array(Bufbyte, len);
405 memcpy(copied, newnonreloc + offset, len);
406 Lstream_write(XLSTREAM(function), copied, len);
408 int speccount = specpdl_depth();
409 record_unwind_protect(restore_gc_inhibit,
411 (gc_currently_forbidden));
412 gc_currently_forbidden = 1;
413 Lstream_write(XLSTREAM(function),
414 newnonreloc + offset, len);
415 unbind_to(speccount, Qnil);
418 Lstream_write(XLSTREAM(function), newnonreloc + offset,
421 if (print_unbuffered)
422 Lstream_flush(XLSTREAM(function));
423 } else if (BUFFERP(function)) {
424 CHECK_LIVE_BUFFER(function);
425 buffer_insert_string(XBUFFER(function), nonreloc, reloc, offset,
427 } else if (MARKERP(function)) {
428 /* marker_position() will err if marker doesn't point anywhere. */
429 Bufpos spoint = marker_position(function);
431 buffer_insert_string_1(XMARKER(function)->buffer,
432 spoint, nonreloc, reloc, offset, len, 0);
433 Fset_marker(function, make_int(spoint + cclen),
434 Fmarker_buffer(function));
435 } else if (FRAMEP(function)) {
436 /* This gets used by functions not invoking print_prepare(),
437 such as Fwrite_char, Fterpri, etc.. */
438 struct frame *f = XFRAME(function);
439 CHECK_LIVE_FRAME(function);
441 if (!EQ(Vprint_message_label, echo_area_status(f)))
442 clear_echo_area_from_print(f, Qnil, 1);
443 echo_area_append(f, nonreloc, reloc, offset, len,
444 Vprint_message_label);
445 } else if (EQ(function, Qt) || EQ(function, Qnil)) {
446 write_string_to_stdio_stream(stdout, 0, newnonreloc, offset,
447 len, Qterminal, print_unbuffered);
449 Charcount ccoff = bytecount_to_charcount(newnonreloc, offset);
452 for (iii = ccoff; iii < cclen + ccoff; iii++) {
454 make_char(charptr_emchar_n(newnonreloc, iii)));
456 newnonreloc = XSTRING_DATA(reloc);
463 #define RESET_PRINT_GENSYM do { \
464 if (!CONSP (Vprint_gensym)) \
465 Vprint_gensym_alist = Qnil; \
468 static Lisp_Object canonicalize_printcharfun(Lisp_Object printcharfun)
470 if (NILP(printcharfun))
471 printcharfun = Vstandard_output;
473 if (EQ(printcharfun, Qt) || NILP(printcharfun))
474 printcharfun = Fselected_frame(Qnil); /* print to minibuffer */
480 print_prepare(Lisp_Object printcharfun, Lisp_Object * frame_kludge)
482 /* Emacs won't print while GCing, but an external debugger might */
488 printcharfun = canonicalize_printcharfun(printcharfun);
490 /* Here we could safely return the canonicalized PRINTCHARFUN.
491 However, if PRINTCHARFUN is a frame, printing of complex
492 structures becomes very expensive, because `append-message'
493 (called by echo_area_append) gets called as many times as
494 output_string() is called (and that's a *lot*). append-message
495 tries to keep top of the message-stack in sync with the contents
496 of " *Echo Area" buffer, consing a new string for each component
497 of the printed structure. For instance, if you print (a a),
498 append-message will cons up the following strings:
506 and will use only the last one. With larger objects, this turns
507 into an O(n^2) consing frenzy that locks up SXEmacs in incessant
510 We prevent this by creating a resizing_buffer stream and letting
511 the printer write into it. print_finish() will notice this
512 stream, and invoke echo_area_append() with the stream's buffer,
514 if (FRAMEP(printcharfun)) {
515 CHECK_LIVE_FRAME(printcharfun);
516 *frame_kludge = printcharfun;
517 printcharfun = make_resizing_buffer_output_stream();
523 static void print_finish(Lisp_Object stream, Lisp_Object frame_kludge)
525 /* Emacs won't print while GCing, but an external debugger might */
531 /* See the comment in print_prepare(). */
532 if (FRAMEP(frame_kludge)) {
533 struct frame *f = XFRAME(frame_kludge);
534 Lstream *str = XLSTREAM(stream);
535 CHECK_LIVE_FRAME(frame_kludge);
538 if (!EQ(Vprint_message_label, echo_area_status(f)))
539 clear_echo_area_from_print(f, Qnil, 1);
540 echo_area_append(f, resizing_buffer_stream_ptr(str),
541 Qnil, 0, Lstream_byte_count(str),
542 Vprint_message_label);
547 /* Used for printing a single-byte character (*not* any Emchar). */
548 #define write_char_internal(string_of_length_1, stream) \
549 output_string (stream, (const Bufbyte *) (string_of_length_1), \
552 /* NOTE: Do not call this with the data of a Lisp_String, as
553 printcharfun might cause a GC, which might cause the string's data
554 to be relocated. To princ a Lisp string, use:
556 print_internal (string, printcharfun, 0);
558 Also note that STREAM should be the result of
559 canonicalize_printcharfun() (i.e. Qnil means stdout, not
560 Vstandard_output, etc.) */
561 void write_string_1(const Bufbyte * str, Bytecount size, Lisp_Object stream)
563 /* This function can GC */
564 #ifdef ERROR_CHECK_BUFPOS
567 output_string(stream, str, Qnil, 0, size);
571 void write_hex_ptr(void* value, Lisp_Object stream)
573 char buf[sizeof(value)*2+1];
574 int n = snprintf(buf,sizeof(buf),"0x%p",value);
575 assert(n>=0 && (size_t)n<sizeof(buf));
576 write_c_string(buf,stream);
579 void write_c_string(const char *str, Lisp_Object stream)
581 /* This function can GC */
582 write_string_1((const Bufbyte *)str, strlen(str), stream);
586 DEFUN("write-char", Fwrite_char, 1, 2, 0, /*
587 Output character CHARACTER to stream STREAM.
588 STREAM defaults to the value of `standard-output' (which see).
592 /* This function can GC */
593 Bufbyte str[MAX_EMCHAR_LEN];
596 CHECK_CHAR_COERCE_INT(character);
597 len = set_charptr_emchar(str, XCHAR(character));
598 output_string(canonicalize_printcharfun(stream), str, Qnil, 0, len);
602 void temp_output_buffer_setup(Lisp_Object bufname)
604 /* This function can GC */
605 struct buffer *old = current_buffer;
609 /* #### This function should accept a Lisp_Object instead of a char *,
610 so that proper translation on the buffer name can occur. */
613 Fset_buffer(Fget_buffer_create(bufname));
615 current_buffer->read_only = Qnil;
618 XSETBUFFER(buf, current_buffer);
619 specbind(Qstandard_output, buf);
621 set_buffer_internal(old);
625 internal_with_output_to_temp_buffer(Lisp_Object bufname,
626 Lisp_Object(*function) (Lisp_Object arg),
627 Lisp_Object arg, Lisp_Object same_frame)
629 int speccount = specpdl_depth();
630 struct gcpro gcpro1, gcpro2, gcpro3;
631 Lisp_Object buf = Qnil;
633 GCPRO3(buf, arg, same_frame);
635 temp_output_buffer_setup(bufname);
636 buf = Vstandard_output;
638 arg = (*function) (arg);
640 temp_output_buffer_show(buf, same_frame);
643 return unbind_to(speccount, arg);
646 DEFUN("with-output-to-temp-buffer", Fwith_output_to_temp_buffer, 1, UNEVALLED, 0, /*
647 Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
648 The buffer is cleared out initially, and marked as unmodified when done.
649 All output done by BODY is inserted in that buffer by default.
650 The buffer is displayed in another window, but not selected.
651 The value of the last form in BODY is returned.
652 If BODY does not finish normally, the buffer BUFNAME is not displayed.
654 If variable `temp-buffer-show-function' is non-nil, call it at the end
655 to get the buffer displayed. It gets one argument, the buffer to display.
659 /* This function can GC */
660 Lisp_Object name = Qnil;
661 int speccount = specpdl_depth();
662 struct gcpro gcpro1, gcpro2;
663 Lisp_Object val = Qnil;
666 /* #### should set the buffer to be translating. See print_internal(). */
670 name = Feval(XCAR(args));
674 temp_output_buffer_setup(name);
677 val = Fprogn(XCDR(args));
679 temp_output_buffer_show(Vstandard_output, Qnil);
681 return unbind_to(speccount, val);
684 DEFUN("terpri", Fterpri, 0, 1, 0, /*
685 Output a newline to STREAM.
686 If STREAM is omitted or nil, the value of `standard-output' is used.
690 /* This function can GC */
691 write_char_internal("\n", canonicalize_printcharfun(stream));
695 DEFUN("prin1", Fprin1, 1, 2, 0, /*
696 Output the printed representation of OBJECT, any Lisp object.
697 Quoting characters are printed when needed to make output that `read'
698 can handle, whenever this is possible.
699 Output stream is STREAM, or value of `standard-output' (which see).
703 /* This function can GC */
704 Lisp_Object frame = Qnil;
705 struct gcpro gcpro1, gcpro2;
706 GCPRO2(object, stream);
709 stream = print_prepare(stream, &frame);
710 print_internal(object, stream, 1);
711 print_finish(stream, frame);
717 DEFUN("prin1-to-string", Fprin1_to_string, 1, 2, 0, /*
718 Return a string containing the printed representation of OBJECT,
719 any Lisp object. Quoting characters are used when needed to make output
720 that `read' can handle, whenever this is possible, unless the optional
721 second argument NOESCAPE is non-nil.
725 /* This function can GC */
726 Lisp_Object result = Qnil;
727 Lisp_Object stream = make_resizing_buffer_output_stream();
728 Lstream *str = XLSTREAM(stream);
729 /* gcpro OBJECT in case a caller forgot to do so */
730 struct gcpro gcpro1, gcpro2, gcpro3;
731 GCPRO3(object, stream, result);
735 print_internal(object, stream, NILP(noescape));
739 result = make_string(resizing_buffer_stream_ptr(str),
740 Lstream_byte_count(str));
745 DEFUN("princ", Fprinc, 1, 2, 0, /*
746 Output the printed representation of OBJECT, any Lisp object.
747 No quoting characters are used; no delimiters are printed around
748 the contents of strings.
749 Output stream is STREAM, or value of `standard-output' (which see).
753 /* This function can GC */
754 Lisp_Object frame = Qnil;
755 struct gcpro gcpro1, gcpro2;
757 GCPRO2(object, stream);
758 stream = print_prepare(stream, &frame);
760 print_internal(object, stream, 0);
761 print_finish(stream, frame);
766 DEFUN("print", Fprint, 1, 2, 0, /*
767 Output the printed representation of OBJECT, with newlines around it.
768 Quoting characters are printed when needed to make output that `read'
769 can handle, whenever this is possible.
770 Output stream is STREAM, or value of `standard-output' (which see).
774 /* This function can GC */
775 Lisp_Object frame = Qnil;
776 struct gcpro gcpro1, gcpro2;
778 GCPRO2(object, stream);
779 stream = print_prepare(stream, &frame);
781 write_char_internal("\n", stream);
782 print_internal(object, stream, 1);
783 write_char_internal("\n", stream);
784 print_finish(stream, frame);
789 /* Print an error message for the error DATA to STREAM. This is a
790 complete implementation of `display-error', which used to be in
791 Lisp (see prim/cmdloop.el). It was ported to C so it can be used
792 efficiently by Ferror_message_string. Fdisplay_error and
793 Ferror_message_string are trivial wrappers around this function.
795 STREAM should be the result of canonicalize_printcharfun(). */
797 print_error_message(Lisp_Object error_object, Lisp_Object stream)
799 /* This function can GC */
800 Lisp_Object type = Fcar_safe(error_object);
801 Lisp_Object method = Qnil;
804 /* No need to GCPRO anything under the assumption that ERROR_OBJECT
807 if (!(CONSP(error_object) && SYMBOLP(type))) {
808 Lisp_Object foo = Fget(type, Qerror_conditions, Qnil);
814 tail = XCDR(error_object);
815 while (!NILP(tail)) {
821 tail = Fget(type, Qerror_conditions, Qnil);
822 while (!NILP(tail)) {
823 if (!(CONSP(tail) && SYMBOLP(XCAR(tail))))
825 else if (!NILP(Fget(XCAR(tail), Qdisplay_error, Qnil))) {
826 method = Fget(XCAR(tail), Qdisplay_error, Qnil);
834 int speccount = specpdl_depth();
835 Lisp_Object frame = Qnil;
839 specbind(Qprint_message_label, Qerror);
840 stream = print_prepare(stream, &frame);
842 tail = Fcdr(error_object);
843 if (EQ(type, Qerror)) {
844 print_internal(Fcar(tail), stream, 0);
847 Lisp_Object errmsg = Fget(type, Qerror_message, Qnil);
849 print_internal(type, stream, 0);
851 print_internal(LISP_GETTEXT(errmsg), stream, 0);
853 while (!NILP(tail)) {
854 write_c_string(first ? ": " : ", ", stream);
855 print_internal(Fcar(tail), stream, 1);
859 print_finish(stream, frame);
861 unbind_to(speccount, Qnil);
868 write_c_string(GETTEXT("Peculiar error "), stream);
869 print_internal(error_object, stream, 1);
872 call2(method, error_object, stream);
876 DEFUN("error-message-string", Ferror_message_string, 1, 1, 0, /*
877 Convert ERROR-OBJECT to an error message, and return it.
879 The format of ERROR-OBJECT should be (ERROR-SYMBOL . DATA). The
880 message is equivalent to the one that would be issued by
881 `display-error' with the same argument.
885 /* This function can GC */
886 Lisp_Object result = Qnil;
887 Lisp_Object stream = make_resizing_buffer_output_stream();
891 print_error_message(error_object, stream);
892 Lstream_flush(XLSTREAM(stream));
893 result = make_string(resizing_buffer_stream_ptr(XLSTREAM(stream)),
894 Lstream_byte_count(XLSTREAM(stream)));
895 Lstream_delete(XLSTREAM(stream));
901 DEFUN("display-error", Fdisplay_error, 2, 2, 0, /*
902 Display ERROR-OBJECT on STREAM in a user-friendly way.
904 (error_object, stream))
906 /* This function can GC */
907 print_error_message(error_object, canonicalize_printcharfun(stream));
913 Lisp_Object Vfloat_output_format;
915 void float_to_string(char *buf, fpfloat data, int maxlen);
918 * This buffer should be at least as large as the max string size of the
919 * largest float, printed in the biggest notation. This is undoubtedly
920 * 20d float_output_format, with the negative of the C-constant "HUGE"
923 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
925 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
926 * case of -1e307 in 20d float_output_format. What is one to do (short of
927 * re-writing _doprnt to be more sane)?
930 void float_to_string(char *buf, fpfloat data, int maxlen)
935 if (NILP(Vfloat_output_format) || !STRINGP(Vfloat_output_format)) {
938 sz = snprintf(buf, maxlen, "%.16g", data);
939 #elif fpfloat_long_double_p
940 sz = snprintf(buf, maxlen, "%.16Lg", data);
942 assert(sz>=0 && sz<maxlen);
943 } else { /* oink oink */
945 /* Check that the spec we have is fully valid.
946 This means not only valid for printf,
947 but meant for floats, and reasonable. */
948 cp = XSTRING_DATA(Vfloat_output_format);
956 for (width = 0; (c = *cp, isdigit(c)); cp++) {
961 if (*cp != 'e' && *cp != 'f' && *cp != 'g' && *cp != 'E'
965 if (width < (int)(*cp != 'e' && *cp != 'E') || width > DBL_DIG)
971 sz = snprintf(buf, maxlen,
972 (char *)XSTRING_DATA(Vfloat_output_format), data);
973 assert(sz>=0 && sz < maxlen);
976 /* added by jwz: don't allow "1.0" to print as "1"; that destroys
977 the read-equivalence of lisp objects. (* x 1) and (* x 1.0) do
978 not do the same thing, so it's important that the printed
979 representation of that form not be corrupted by the printer.
982 Bufbyte *s = (Bufbyte *) buf; /* don't use signed chars here!
983 isdigit() can't hack them! */
990 /* if there's a non-digit, then there is a decimal point, or
991 it's in exponential notation, both of which are ok. */
994 /* otherwise, we need to hack it. */
1003 /* Some machines print "0.4" as ".4". I don't like that. */
1004 if (buf[0] == '.' || (buf[0] == '-' && buf[1] == '.')) {
1007 for (i = strlen(buf) + 1; i >= 0; i--)
1008 buf[i + 1] = buf[i];
1009 buf[(buf[0] == '-' ? 1 : 0)] = '0';
1012 #endif /* HAVE_FPFLOAT */
1014 /* Print NUMBER to BUFFER.
1015 This is equivalent to snprintf (buffer, maxlen, "%ld", number), only much faster.
1017 BUFFER should accept 24 bytes. This should suffice for the longest
1018 numbers on 64-bit machines, including the `-' sign and the trailing
1019 '\0'. Returns a pointer to the trailing '\0'. */
1020 char *long_to_string(char *buffer, long number, int maxlen)
1022 #if (SIZEOF_LONG != 4) && (SIZEOF_LONG != 8)
1024 int sz = snprintf(buffer, maxlen, "%ld", number);
1025 assert(sz>=0 && sz < maxlen);
1026 return buffer + strlen(buffer);
1027 #else /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
1035 #define FROB(figure) \
1037 if (force || number >= figure) { \
1038 *p++ = number / figure + '0'; \
1045 #if SIZEOF_LONG == 8
1046 FROB(1000000000000000000L);
1047 FROB(100000000000000000L);
1048 FROB(10000000000000000L);
1049 FROB(1000000000000000L);
1050 FROB(100000000000000L);
1051 FROB(10000000000000L);
1052 FROB(1000000000000L);
1053 FROB(100000000000L);
1055 #endif /* SIZEOF_LONG == 8 */
1066 *p++ = number + '0';
1069 #endif /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
1073 print_vector_internal(const char *start, const char *end,
1074 Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1076 /* This function can GC */
1078 int len = XVECTOR_LENGTH(obj);
1080 struct gcpro gcpro1, gcpro2;
1081 GCPRO2(obj, printcharfun);
1083 if (INTP(Vprint_length)) {
1084 int max = XINT(Vprint_length);
1089 write_c_string(start, printcharfun);
1090 for (i = 0; i < last; i++) {
1091 Lisp_Object elt = XVECTOR_DATA(obj)[i];
1093 write_char_internal(" ", printcharfun);
1094 print_internal(elt, printcharfun, escapeflag);
1098 write_c_string(" ...", printcharfun);
1099 write_c_string(end, printcharfun);
1102 void print_cons(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1104 /* This function can GC */
1105 struct gcpro gcpro1, gcpro2;
1107 /* If print_readably is on, print (quote -foo-) as '-foo-
1108 (Yeah, this should really be what print-pretty does, but we
1109 don't have the rest of a pretty printer, and this actually
1110 has non-negligible impact on size/speed of .elc files.)
1112 if (print_readably &&
1113 EQ(XCAR(obj), Qquote) &&
1114 CONSP(XCDR(obj)) && NILP(XCDR(XCDR(obj)))) {
1115 obj = XCAR(XCDR(obj));
1116 GCPRO2(obj, printcharfun);
1117 write_char_internal("\'", printcharfun);
1119 print_internal(obj, printcharfun, escapeflag);
1123 GCPRO2(obj, printcharfun);
1124 write_char_internal("(", printcharfun);
1128 int max = INTP(Vprint_length) ? XINT(Vprint_length) : INT_MAX;
1129 Lisp_Object tortoise;
1130 /* Use tortoise/hare to make sure circular lists don't infloop */
1132 for (tortoise = obj, len = 0;
1133 CONSP(obj); obj = XCDR(obj), len++) {
1135 write_char_internal(" ", printcharfun);
1136 if (EQ(obj, tortoise) && len > 0) {
1139 ("printing unreadable circular list");
1141 write_c_string("... <circular list>",
1146 tortoise = XCDR(tortoise);
1148 write_c_string("...", printcharfun);
1151 print_internal(XCAR(obj), printcharfun, escapeflag);
1155 write_c_string(" . ", printcharfun);
1156 print_internal(obj, printcharfun, escapeflag);
1160 write_char_internal(")", printcharfun);
1164 void print_vector(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1166 print_vector_internal("[", "]", obj, printcharfun, escapeflag);
1169 void print_string(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1171 Lisp_String *s = XSTRING(obj);
1172 /* We distinguish between Bytecounts and Charcounts, to make
1173 Vprint_string_length work correctly under Mule. */
1174 Charcount size = string_char_length(s);
1175 Charcount max = size;
1176 Bytecount bcmax = string_length(s);
1177 struct gcpro gcpro1, gcpro2;
1178 GCPRO2(obj, printcharfun);
1180 if (INTP(Vprint_string_length) && XINT(Vprint_string_length) < max) {
1181 max = XINT(Vprint_string_length);
1182 bcmax = charcount_to_bytecount(string_data(s), max);
1190 /* This deals with GC-relocation and Mule. */
1191 output_string(printcharfun, 0, obj, 0, bcmax);
1193 write_c_string(" ...", printcharfun);
1195 Bytecount i, last = 0;
1197 write_char_internal("\"", printcharfun);
1198 for (i = 0; i < bcmax; i++) {
1199 Bufbyte ch = string_byte(s, i);
1200 if (ch == '\"' || ch == '\\'
1201 || (ch == '\n' && print_escape_newlines)) {
1203 output_string(printcharfun, 0, obj,
1207 write_c_string("\\n", printcharfun);
1209 write_char_internal("\\", printcharfun);
1210 /* This is correct for Mule because the
1211 character is either \ or " */
1212 write_char_internal(string_data(s) + i,
1219 output_string(printcharfun, 0, obj, last, bcmax - last);
1222 write_c_string(" ...", printcharfun);
1223 write_char_internal("\"", printcharfun);
1229 default_object_printer(Lisp_Object obj, Lisp_Object printcharfun,
1232 struct lcrecord_header *header = (struct lcrecord_header *)XPNTR(obj);
1235 error("printing unreadable object #<%s 0x%x>",
1236 LHEADER_IMPLEMENTATION(&header->lheader)->name,
1239 write_fmt_string(printcharfun, "#<%s 0x%x>",
1240 LHEADER_IMPLEMENTATION(&header->lheader)->name, header->uid);
1244 internal_object_printer(Lisp_Object obj, Lisp_Object printcharfun,
1247 write_fmt_string(printcharfun, "#<INTERNAL OBJECT (SXEmacs bug?) (%s) 0x%lx>",
1248 XRECORD_LHEADER_IMPLEMENTATION(obj)->name,
1249 (unsigned long)XPNTR(obj));
1252 enum printing_badness {
1253 BADNESS_INTEGER_OBJECT,
1254 BADNESS_POINTER_OBJECT,
1259 printing_major_badness(Lisp_Object printcharfun,
1260 Char_ASCII * badness_string, int type, void *val,
1261 enum printing_badness badness)
1267 case BADNESS_INTEGER_OBJECT:
1268 len = snprintf(buf, sizeof(buf), "%s %d object %ld", badness_string, type,
1272 case BADNESS_POINTER_OBJECT:
1273 len = snprintf(buf, sizeof(buf), "%s %d object %p", badness_string, type, val);
1276 case BADNESS_NO_TYPE:
1277 len = snprintf(buf, sizeof(buf), "%s object %p", badness_string, val);
1280 len = snprintf(buf, sizeof(buf), "%s unknown badness %d",
1281 badness_string, badness);
1284 assert(len >= 0 && (size_t)len < sizeof(buf));
1286 /* Don't abort or signal if called from debug_print() or already
1288 if (!inhibit_non_essential_printing_operations) {
1289 #ifdef ERROR_CHECK_TYPES
1291 #else /* not ERROR_CHECK_TYPES */
1293 type_error(Qinternal_error, "printing %s", buf);
1294 #endif /* not ERROR_CHECK_TYPES */
1296 write_fmt_string(printcharfun,
1297 "#<EMACS BUG: %s Save your buffers immediately and "
1298 "please report this bug>", buf);
1302 print_internal(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1304 /* This function can GC */
1305 /* defined in emacs.c */
1306 extern int inhibit_autoloads, nodumpfile;
1310 /* Emacs won't print while GCing, but an external debugger might */
1315 /* #### Both input and output streams should have a flag associated
1316 with them indicating whether output to that stream, or strings
1317 read from the stream, get translated using Fgettext(). Such a
1318 stream is called a "translating stream". For the minibuffer and
1319 external-debugging-output this is always true on output, and
1320 with-output-to-temp-buffer sets the flag to true for the buffer
1321 it creates. This flag should also be user-settable. Perhaps it
1322 should be split up into two flags, one for input and one for
1326 /* Try out custom printing */
1327 if (UNLIKELY(!(bool)inhibit_autoloads && !(bool)nodumpfile) &&
1328 !EQ(Qnil, Vcustom_object_printer) &&
1329 !EQ(Qnil, apply1(Vcustom_object_printer,
1330 Fcons(obj, Fcons(printcharfun, Qnil))))) {
1334 /* Detect circularities and truncate them.
1335 No need to offer any alternative--this is better than an error. */
1336 if (CONSP(obj) || VECTORP(obj) || COMPILED_FUNCTIONP(obj)) {
1338 for (i = 0; i < print_depth; i++)
1339 if (EQ(obj, being_printed[i])) {
1342 long_to_string(buf + 1, i, sizeof(buf)-1);
1343 write_c_string(buf, printcharfun);
1348 being_printed[print_depth] = obj;
1351 if (print_depth > PRINT_CIRCLE) {
1352 error("Apparently circular structure being printed");
1355 switch (XTYPE(obj)) {
1356 case Lisp_Type_Int_Even:
1357 case Lisp_Type_Int_Odd: {
1358 /* ASCII Decimal representation uses 2.4 times as many bits as
1360 char buf[3 * sizeof(EMACS_INT) + 5];
1361 long_to_string(buf, XINT(obj),sizeof(buf));
1362 write_c_string(buf, printcharfun);
1366 case Lisp_Type_Char: {
1367 /* God intended that this be #\..., you know. */
1369 memset(buf, 0, sizeof(buf));
1370 Emchar ch = XCHAR(obj);
1388 if ((ch + 64) == '\\')
1392 } else if (ch < 127) {
1393 /* syntactically special characters should be
1415 } else if (ch == 127) {
1416 *p++ = '\\', *p++ = '^', *p++ = '?';
1417 } else if (ch < 160) {
1418 *p++ = '\\', *p++ = '^';
1419 p += set_charptr_emchar((Bufbyte *) p, ch + 64);
1421 p += set_charptr_emchar((Bufbyte *) p, ch);
1424 output_string(printcharfun, (Bufbyte *) buf, Qnil, 0,
1430 case Lisp_Type_Record: {
1431 struct lrecord_header *lheader = XRECORD_LHEADER(obj);
1433 /* Try to check for various sorts of bogus pointers if we're in
1434 a situation where it may be likely -- i.e. called from
1435 debug_print() or we're already crashing. In such cases,
1436 (further) crashing is counterproductive. */
1438 if (inhibit_non_essential_printing_operations &&
1439 !debug_can_access_memory(lheader, sizeof(*lheader))) {
1440 write_fmt_string(printcharfun,
1441 "#<EMACS BUG: BAD MEMORY ACCESS %p>",
1446 if (CONSP(obj) || VECTORP(obj)) {
1447 /* If deeper than spec'd depth, print placeholder. */
1448 if (INTP(Vprint_level)
1449 && print_depth > XINT(Vprint_level)) {
1450 write_c_string("...", printcharfun);
1455 if (lheader->type == lrecord_type_free) {
1456 printing_major_badness(printcharfun,
1461 } else if (lheader->type == lrecord_type_undefined) {
1462 printing_major_badness(printcharfun,
1463 "lrecord_type_undefined",
1467 } else if (lheader->type >= lrecord_type_count) {
1468 printing_major_badness(printcharfun,
1469 "illegal lrecord type",
1470 (int)(lheader->type),
1472 BADNESS_POINTER_OBJECT);
1476 /* Further checks for bad memory in critical situations. We
1477 don't normally do these because they may be expensive or
1478 weird (e.g. under Unix we typically have to set a SIGSEGV
1479 handler and try to trigger a seg fault). */
1481 if (inhibit_non_essential_printing_operations) {
1482 const struct lrecord_implementation *imp =
1483 LHEADER_IMPLEMENTATION(lheader);
1485 if (!debug_can_access_memory
1486 (lheader, imp->size_in_bytes_method ?
1487 imp->size_in_bytes_method(lheader) :
1488 imp->static_size)) {
1491 "#<EMACS BUG: type %s "
1492 "BAD MEMORY ACCESS %p>",
1493 LHEADER_IMPLEMENTATION
1494 (lheader)->name, lheader);
1499 Lisp_String *l = (Lisp_String *)lheader;
1500 if (!debug_can_access_memory(
1501 l->data, l->size)) {
1505 "(CAN'T ACCESS STRING "
1506 "DATA %p)>", lheader, l->data);
1512 if (LHEADER_IMPLEMENTATION(lheader)->printer) {
1513 ((LHEADER_IMPLEMENTATION(lheader)->printer)
1514 (obj, printcharfun, escapeflag));
1516 default_object_printer(obj, printcharfun, escapeflag);
1522 /* We're in trouble if this happens! */
1523 printing_major_badness(printcharfun,
1524 "illegal data type", XTYPE(obj),
1526 BADNESS_INTEGER_OBJECT);
1535 void print_symbol(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1537 /* This function can GC */
1538 /* #### Bug!! (intern "") isn't printed in some distinguished way */
1539 /* #### (the reader also loses on it) */
1540 Lisp_String *name = symbol_name(XSYMBOL(obj));
1541 Bytecount size = string_length(name);
1542 struct gcpro gcpro1, gcpro2;
1545 /* This deals with GC-relocation */
1546 Lisp_Object nameobj;
1547 XSETSTRING(nameobj, name);
1548 output_string(printcharfun, 0, nameobj, 0, size);
1551 GCPRO2(obj, printcharfun);
1553 /* If we print an uninterned symbol as part of a complex object and
1554 the flag print-gensym is non-nil, prefix it with #n= to read the
1555 object back with the #n# reader syntax later if needed. */
1556 if (!NILP(Vprint_gensym)
1557 /* #### Test whether this produces a noticeable slow-down for
1558 printing when print-gensym is non-nil. */
1559 && !EQ(obj, oblookup(Vobarray,
1560 string_data(symbol_name(XSYMBOL(obj))),
1561 string_length(symbol_name(XSYMBOL(obj)))))) {
1562 if (print_depth > 1) {
1563 Lisp_Object tem = Fassq(obj, Vprint_gensym_alist);
1565 write_char_internal("#", printcharfun);
1566 print_internal(XCDR(tem), printcharfun,
1568 write_char_internal("#", printcharfun);
1572 if (CONSP(Vprint_gensym_alist)) {
1573 /* Vprint_gensym_alist is exposed to Lisp, so we
1574 have to be careful. */
1575 CHECK_CONS(XCAR(Vprint_gensym_alist));
1577 (XCAR(Vprint_gensym_alist)));
1581 (Vprint_gensym_alist))) +
1585 Vprint_gensym_alist =
1586 Fcons(Fcons(obj, tem), Vprint_gensym_alist);
1588 write_char_internal("#", printcharfun);
1589 print_internal(tem, printcharfun, escapeflag);
1590 write_char_internal("=", printcharfun);
1593 write_c_string("#:", printcharfun);
1596 /* Does it look like an integer or a float? */
1598 Bufbyte *data = string_data(name);
1599 Bytecount confusing = 0;
1602 goto not_yet_confused; /* Really confusing */
1603 else if (isdigit(data[0]))
1606 goto not_yet_confused;
1607 else if (data[0] == '-' || data[0] == '+')
1610 goto not_yet_confused;
1612 for (; confusing < size; confusing++) {
1613 if (!isdigit(data[confusing])) {
1622 /* #### Ugh, this is needlessly complex and slow for what we
1623 need here. It might be a good idea to copy equivalent code
1624 from FSF. --hniksic */
1625 confusing = isfloat_string((char *)data);
1628 write_char_internal("\\", printcharfun);
1632 Lisp_Object nameobj;
1636 XSETSTRING(nameobj, name);
1637 for (i = 0; i < size; i++) {
1638 switch (string_byte(name, i)) {
1686 output_string(printcharfun, 0, nameobj,
1688 write_char_internal("\\", printcharfun);
1694 output_string(printcharfun, 0, nameobj, last, size - last);
1699 /* Useful on systems or in places where writing to stdout is unavailable or
1702 static int alternate_do_pointer;
1703 static char alternate_do_string[5000];
1705 DEFUN("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0, /*
1706 Append CHARACTER to the array `alternate_do_string'.
1707 This can be used in place of `external-debugging-output' as a function
1708 to be passed to `print'. Before calling `print', set `alternate_do_pointer'
1713 Bufbyte str[MAX_EMCHAR_LEN];
1716 const Extbyte *extptr = NULL;
1718 CHECK_CHAR_COERCE_INT(character);
1719 len = set_charptr_emchar(str, XCHAR(character));
1720 TO_EXTERNAL_FORMAT(DATA, (str, len),
1721 ALLOCA, (extptr, extlen), Qterminal);
1722 if ( extptr != NULL ) {
1723 memcpy(alternate_do_string + alternate_do_pointer, extptr, extlen);
1724 alternate_do_pointer += extlen;
1725 alternate_do_string[alternate_do_pointer] = 0;
1727 /* Better bad transcoding than nothing I guess... */
1728 memcpy(alternate_do_string + alternate_do_pointer, str, len);
1729 alternate_do_pointer += len;
1730 alternate_do_string[alternate_do_pointer] = 0;
1735 DEFUN("external-debugging-output", Fexternal_debugging_output, 1, 3, 0, /*
1736 Write CHAR-OR-STRING to stderr or stdout.
1737 If optional arg STDOUT-P is non-nil, write to stdout; otherwise, write
1738 to stderr. You can use this function to write directly to the terminal.
1739 This function can be used as the STREAM argument of Fprint() or the like.
1741 Under MS Windows, this writes output to the console window (which is
1742 created, if necessary), unless SXEmacs is being run noninteractively
1743 \(i.e. using the `-batch' argument).
1745 If you have opened a termscript file (using `open-termscript'), then
1746 the output also will be logged to this file.
1748 (char_or_string, stdout_p, device))
1751 struct console *con = NULL;
1754 if (!NILP(stdout_p))
1759 CHECK_LIVE_DEVICE(device);
1760 if (!DEVICE_TTY_P(XDEVICE(device)) &&
1761 !DEVICE_STREAM_P(XDEVICE(device)))
1762 signal_simple_error("Must be tty or stream device",
1764 con = XCONSOLE(DEVICE_CONSOLE(XDEVICE(device)));
1765 if (DEVICE_TTY_P(XDEVICE(device))) {
1767 } else if (!NILP(stdout_p)) {
1768 file = CONSOLE_STREAM_DATA(con)->out;
1770 file = CONSOLE_STREAM_DATA(con)->err;
1774 if (STRINGP(char_or_string))
1775 write_string_to_stdio_stream(file, con,
1776 XSTRING_DATA(char_or_string),
1777 0, XSTRING_LENGTH(char_or_string),
1780 Bufbyte str[MAX_EMCHAR_LEN];
1783 CHECK_CHAR_COERCE_INT(char_or_string);
1784 len = set_charptr_emchar(str, XCHAR(char_or_string));
1785 write_string_to_stdio_stream(file, con, str, 0, len, Qterminal,
1789 return char_or_string;
1792 DEFUN("open-termscript", Fopen_termscript, 1, 1, "FOpen termscript file: ", /*
1793 Start writing all terminal output to FILENAME as well as the terminal.
1794 FILENAME = nil means just close any termscript file currently open.
1798 /* This function can GC */
1799 if (termscript != 0) {
1804 if (!NILP(filename)) {
1805 filename = Fexpand_file_name(filename, Qnil);
1806 termscript = fopen((char *)XSTRING_DATA(filename), "w");
1807 if (termscript == NULL)
1808 report_file_error("Opening termscript",
1815 /* Debugging kludge -- unbuffered */
1816 static int debug_print_length = 50;
1817 static int debug_print_level = 15;
1818 static int debug_print_readably = -1;
1820 static void debug_print_no_newline(Lisp_Object debug_print_obj)
1822 /* This function can GC */
1823 int save_print_readably = print_readably;
1824 int save_print_depth = print_depth;
1825 Lisp_Object save_Vprint_length = Vprint_length;
1826 Lisp_Object save_Vprint_level = Vprint_level;
1827 Lisp_Object save_Vinhibit_quit = Vinhibit_quit;
1828 struct gcpro gcpro1, gcpro2, gcpro3;
1829 GCPRO3(save_Vprint_level, save_Vprint_length, save_Vinhibit_quit);
1833 ("** gc-in-progress! Bad idea to print anything! **\n");
1836 print_readably = debug_print_readably != -1 ? debug_print_readably : 0;
1838 inhibit_non_essential_printing_operations = 1;
1839 /* Could use unwind-protect, but why bother? */
1840 if (debug_print_length > 0)
1841 Vprint_length = make_int(debug_print_length);
1842 if (debug_print_level > 0)
1843 Vprint_level = make_int(debug_print_level);
1845 print_internal(debug_print_obj, Qexternal_debugging_output, 1);
1846 alternate_do_pointer = 0;
1847 print_internal(debug_print_obj, Qalternate_debugging_output, 1);
1849 Vinhibit_quit = save_Vinhibit_quit;
1850 Vprint_level = save_Vprint_level;
1851 Vprint_length = save_Vprint_length;
1852 print_depth = save_print_depth;
1853 print_readably = save_print_readably;
1854 inhibit_non_essential_printing_operations = 0;
1859 void debug_print(Lisp_Object debug_print_obj)
1861 debug_print_no_newline(debug_print_obj);
1865 /* Debugging kludge -- unbuffered */
1866 /* This function provided for the benefit of the debugger. */
1867 void debug_backtrace(void)
1869 /* This function can GC */
1870 int old_print_readably = print_readably;
1871 int old_print_depth = print_depth;
1872 Lisp_Object old_print_length = Vprint_length;
1873 Lisp_Object old_print_level = Vprint_level;
1874 Lisp_Object old_inhibit_quit = Vinhibit_quit;
1876 struct gcpro gcpro1, gcpro2, gcpro3;
1877 GCPRO3(old_print_level, old_print_length, old_inhibit_quit);
1881 ("** gc-in-progress! Bad idea to print anything! **\n");
1886 inhibit_non_essential_printing_operations = 1;
1887 /* Could use unwind-protect, but why bother? */
1888 if (debug_print_length > 0)
1889 Vprint_length = make_int(debug_print_length);
1890 if (debug_print_level > 0)
1891 Vprint_level = make_int(debug_print_level);
1893 Fbacktrace(Qexternal_debugging_output, Qt);
1896 Vinhibit_quit = old_inhibit_quit;
1897 Vprint_level = old_print_level;
1898 Vprint_length = old_print_length;
1899 print_depth = old_print_depth;
1900 print_readably = old_print_readably;
1901 inhibit_non_essential_printing_operations = 0;
1907 void debug_short_backtrace(int length)
1910 struct backtrace *bt = backtrace_list;
1912 while (length > 0 && bt) {
1916 if (COMPILED_FUNCTIONP(*bt->function)) {
1917 #if defined(COMPILED_FUNCTION_ANNOTATION_HACK)
1919 compiled_function_annotation(XCOMPILED_FUNCTION
1922 Lisp_Object ann = Qnil;
1925 stderr_out("<compiled-function from ");
1926 debug_print_no_newline(ann);
1930 ("<compiled-function of unknown origin>");
1933 debug_print_no_newline(*bt->function);
1941 #endif /* debugging kludge */
1943 void syms_of_print(void)
1945 defsymbol(&Qstandard_output, "standard-output");
1947 defsymbol(&Qprint_length, "print-length");
1949 defsymbol(&Qprint_string_length, "print-string-length");
1951 defsymbol(&Qdisplay_error, "display-error");
1952 defsymbol(&Qprint_message_label, "print-message-label");
1955 DEFSUBR(Fprin1_to_string);
1958 DEFSUBR(Ferror_message_string);
1959 DEFSUBR(Fdisplay_error);
1961 DEFSUBR(Fwrite_char);
1962 DEFSUBR(Falternate_debugging_output);
1963 DEFSUBR(Fexternal_debugging_output);
1964 DEFSUBR(Fopen_termscript);
1965 defsymbol(&Qexternal_debugging_output, "external-debugging-output");
1966 defsymbol(&Qalternate_debugging_output, "alternate-debugging-output");
1967 DEFSUBR(Fwith_output_to_temp_buffer);
1970 void reinit_vars_of_print(void)
1972 alternate_do_pointer = 0;
1975 void vars_of_print(void)
1977 reinit_vars_of_print();
1979 DEFVAR_LISP("standard-output", &Vstandard_output /*
1980 Output stream `print' uses by default for outputting a character.
1981 This may be any function of one argument.
1982 It may also be a buffer (output is inserted before point)
1983 or a marker (output is inserted and the marker is advanced)
1984 or the symbol t (output appears in the minibuffer line).
1986 Vstandard_output = Qt;
1989 DEFVAR_LISP("float-output-format", &Vfloat_output_format /*
1990 The format descriptor string that lisp uses to print floats.
1991 This is a %-spec like those accepted by `printf' in C,
1992 but with some restrictions. It must start with the two characters `%.'.
1993 After that comes an integer precision specification,
1994 and then a letter which controls the format.
1995 The letters allowed are `e', `f' and `g'.
1996 Use `e' for exponential notation "DIG.DIGITSeEXPT"
1997 Use `f' for decimal point notation "DIGITS.DIGITS".
1998 Use `g' to choose the shorter of those two formats for the number at hand.
1999 The precision in any of these cases is the number of digits following
2000 the decimal point. With `f', a precision of 0 means to omit the
2001 decimal point. 0 is not allowed with `f' or `g'.
2003 A value of nil means to use `%.16g'.
2005 Regardless of the value of `float-output-format', a floating point number
2006 will never be printed in such a way that it is ambiguous with an integer;
2007 that is, a floating-point number will always be printed with a decimal
2008 point and/or an exponent, even if the digits following the decimal point
2009 are all zero. This is to preserve read-equivalence.
2011 Vfloat_output_format = Qnil;
2012 #endif /* HAVE_FPFLOAT */
2014 DEFVAR_LISP("print-length", &Vprint_length /*
2015 Maximum length of list or vector to print before abbreviating.
2016 A value of nil means no limit.
2018 Vprint_length = Qnil;
2020 DEFVAR_LISP("print-string-length", &Vprint_string_length /*
2021 Maximum length of string to print before abbreviating.
2022 A value of nil means no limit.
2024 Vprint_string_length = Qnil;
2026 DEFVAR_LISP("print-level", &Vprint_level /*
2027 Maximum depth of list nesting to print before abbreviating.
2028 A value of nil means no limit.
2030 Vprint_level = Qnil;
2032 DEFVAR_BOOL("print-escape-newlines", &print_escape_newlines /*
2033 Non-nil means print newlines in strings as backslash-n.
2035 print_escape_newlines = 0;
2037 DEFVAR_BOOL("print-readably", &print_readably /*
2038 If non-nil, then all objects will be printed in a readable form.
2039 If an object has no readable representation, then an error is signalled.
2040 When print-readably is true, compiled-function objects will be written in
2041 #[...] form instead of in #<compiled-function [...]> form, and two-element
2042 lists of the form (quote object) will be written as the equivalent 'object.
2043 Do not SET this variable; bind it instead.
2047 /* #### I think this should default to t. But we'd better wait
2048 until we see that it works out. */
2049 DEFVAR_LISP("print-gensym", &Vprint_gensym /*
2050 If non-nil, then uninterned symbols will be printed specially.
2051 Uninterned symbols are those which are not present in `obarray', that is,
2052 those which were made with `make-symbol' or by calling `intern' with a
2055 When print-gensym is true, such symbols will be preceded by "#:",
2056 which causes the reader to create a new symbol instead of interning
2057 and returning an existing one. Beware: the #: syntax creates a new
2058 symbol each time it is seen, so if you print an object which contains
2059 two pointers to the same uninterned symbol, `read' will not duplicate
2062 If the value of `print-gensym' is a cons cell, then in addition
2063 refrain from clearing `print-gensym-alist' on entry to and exit from
2064 printing functions, so that the use of #...# and #...= can carry over
2065 for several separately printed objects.
2067 Vprint_gensym = Qnil;
2069 DEFVAR_LISP("print-gensym-alist", &Vprint_gensym_alist /*
2070 Association list of elements (GENSYM . N) to guide use of #N# and #N=.
2071 In each element, GENSYM is an uninterned symbol that has been associated
2072 with #N= for the specified value of N.
2074 Vprint_gensym_alist = Qnil;
2076 DEFVAR_LISP("print-message-label", &Vprint_message_label /*
2077 Label for minibuffer messages created with `print'. This should
2078 generally be bound with `let' rather than set. (See `display-message'.)
2080 Vprint_message_label = Qprint;
2082 DEFVAR_LISP("custom-object-printer", &Vcustom_object_printer /*
2083 Function to call in order to print custom object.
2085 Vcustom_object_printer = Qnil;