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;
916 * This buffer should be at least as large as the max string size of the
917 * largest float, printed in the biggest notation. This is undoubtedly
918 * 20d float_output_format, with the negative of the C-constant "HUGE"
921 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
923 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
924 * case of -1e307 in 20d float_output_format. What is one to do (short of
925 * re-writing _doprnt to be more sane)?
928 void float_to_string(char *buf, fpfloat data, int maxlen)
933 if (NILP(Vfloat_output_format) || !STRINGP(Vfloat_output_format)) {
936 sz = snprintf(buf, maxlen, "%.16g", data);
937 #elif fpfloat_long_double_p
938 sz = snprintf(buf, maxlen, "%.16Lg", data);
940 assert(sz>=0 && sz<maxlen);
941 } else { /* oink oink */
943 /* Check that the spec we have is fully valid.
944 This means not only valid for printf,
945 but meant for floats, and reasonable. */
946 cp = XSTRING_DATA(Vfloat_output_format);
954 for (width = 0; (c = *cp, isdigit(c)); cp++) {
959 if (*cp != 'e' && *cp != 'f' && *cp != 'g' && *cp != 'E'
963 if (width < (int)(*cp != 'e' && *cp != 'E') || width > DBL_DIG)
969 sz = snprintf(buf, maxlen,
970 (char *)XSTRING_DATA(Vfloat_output_format), data);
971 assert(sz>=0 && sz < maxlen);
974 /* added by jwz: don't allow "1.0" to print as "1"; that destroys
975 the read-equivalence of lisp objects. (* x 1) and (* x 1.0) do
976 not do the same thing, so it's important that the printed
977 representation of that form not be corrupted by the printer.
980 Bufbyte *s = (Bufbyte *) buf; /* don't use signed chars here!
981 isdigit() can't hack them! */
988 /* if there's a non-digit, then there is a decimal point, or
989 it's in exponential notation, both of which are ok. */
992 /* otherwise, we need to hack it. */
1001 /* Some machines print "0.4" as ".4". I don't like that. */
1002 if (buf[0] == '.' || (buf[0] == '-' && buf[1] == '.')) {
1005 for (i = strlen(buf) + 1; i >= 0; i--)
1006 buf[i + 1] = buf[i];
1007 buf[(buf[0] == '-' ? 1 : 0)] = '0';
1010 #endif /* HAVE_FPFLOAT */
1012 /* Print NUMBER to BUFFER.
1013 This is equivalent to snprintf (buffer, maxlen, "%ld", number), only much faster.
1015 BUFFER should accept 24 bytes. This should suffice for the longest
1016 numbers on 64-bit machines, including the `-' sign and the trailing
1017 '\0'. Returns a pointer to the trailing '\0'. */
1018 char *long_to_string(char *buffer, long number, int maxlen)
1020 #if (SIZEOF_LONG != 4) && (SIZEOF_LONG != 8)
1022 int sz = snprintf(buffer, maxlen, "%ld", number);
1023 assert(sz>=0 && sz < maxlen);
1024 return buffer + strlen(buffer);
1025 #else /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
1033 #define FROB(figure) \
1035 if (force || number >= figure) { \
1036 *p++ = number / figure + '0'; \
1043 #if SIZEOF_LONG == 8
1044 FROB(1000000000000000000L);
1045 FROB(100000000000000000L);
1046 FROB(10000000000000000L);
1047 FROB(1000000000000000L);
1048 FROB(100000000000000L);
1049 FROB(10000000000000L);
1050 FROB(1000000000000L);
1051 FROB(100000000000L);
1053 #endif /* SIZEOF_LONG == 8 */
1064 *p++ = number + '0';
1067 #endif /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
1071 print_vector_internal(const char *start, const char *end,
1072 Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1074 /* This function can GC */
1076 int len = XVECTOR_LENGTH(obj);
1078 struct gcpro gcpro1, gcpro2;
1079 GCPRO2(obj, printcharfun);
1081 if (INTP(Vprint_length)) {
1082 int max = XINT(Vprint_length);
1087 write_c_string(start, printcharfun);
1088 for (i = 0; i < last; i++) {
1089 Lisp_Object elt = XVECTOR_DATA(obj)[i];
1091 write_char_internal(" ", printcharfun);
1092 print_internal(elt, printcharfun, escapeflag);
1096 write_c_string(" ...", printcharfun);
1097 write_c_string(end, printcharfun);
1100 void print_cons(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1102 /* This function can GC */
1103 struct gcpro gcpro1, gcpro2;
1105 /* If print_readably is on, print (quote -foo-) as '-foo-
1106 (Yeah, this should really be what print-pretty does, but we
1107 don't have the rest of a pretty printer, and this actually
1108 has non-negligible impact on size/speed of .elc files.)
1110 if (print_readably &&
1111 EQ(XCAR(obj), Qquote) &&
1112 CONSP(XCDR(obj)) && NILP(XCDR(XCDR(obj)))) {
1113 obj = XCAR(XCDR(obj));
1114 GCPRO2(obj, printcharfun);
1115 write_char_internal("\'", printcharfun);
1117 print_internal(obj, printcharfun, escapeflag);
1121 GCPRO2(obj, printcharfun);
1122 write_char_internal("(", printcharfun);
1126 int max = INTP(Vprint_length) ? XINT(Vprint_length) : INT_MAX;
1127 Lisp_Object tortoise;
1128 /* Use tortoise/hare to make sure circular lists don't infloop */
1130 for (tortoise = obj, len = 0;
1131 CONSP(obj); obj = XCDR(obj), len++) {
1133 write_char_internal(" ", printcharfun);
1134 if (EQ(obj, tortoise) && len > 0) {
1137 ("printing unreadable circular list");
1139 write_c_string("... <circular list>",
1144 tortoise = XCDR(tortoise);
1146 write_c_string("...", printcharfun);
1149 print_internal(XCAR(obj), printcharfun, escapeflag);
1153 write_c_string(" . ", printcharfun);
1154 print_internal(obj, printcharfun, escapeflag);
1158 write_char_internal(")", printcharfun);
1162 void print_vector(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1164 print_vector_internal("[", "]", obj, printcharfun, escapeflag);
1167 void print_string(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1169 Lisp_String *s = XSTRING(obj);
1170 /* We distinguish between Bytecounts and Charcounts, to make
1171 Vprint_string_length work correctly under Mule. */
1172 Charcount size = string_char_length(s);
1173 Charcount max = size;
1174 Bytecount bcmax = string_length(s);
1175 struct gcpro gcpro1, gcpro2;
1176 GCPRO2(obj, printcharfun);
1178 if (INTP(Vprint_string_length) && XINT(Vprint_string_length) < max) {
1179 max = XINT(Vprint_string_length);
1180 bcmax = charcount_to_bytecount(string_data(s), max);
1188 /* This deals with GC-relocation and Mule. */
1189 output_string(printcharfun, 0, obj, 0, bcmax);
1191 write_c_string(" ...", printcharfun);
1193 Bytecount i, last = 0;
1195 write_char_internal("\"", printcharfun);
1196 for (i = 0; i < bcmax; i++) {
1197 Bufbyte ch = string_byte(s, i);
1198 if (ch == '\"' || ch == '\\'
1199 || (ch == '\n' && print_escape_newlines)) {
1201 output_string(printcharfun, 0, obj,
1205 write_c_string("\\n", printcharfun);
1207 write_char_internal("\\", printcharfun);
1208 /* This is correct for Mule because the
1209 character is either \ or " */
1210 write_char_internal(string_data(s) + i,
1217 output_string(printcharfun, 0, obj, last, bcmax - last);
1220 write_c_string(" ...", printcharfun);
1221 write_char_internal("\"", printcharfun);
1227 default_object_printer(Lisp_Object obj, Lisp_Object printcharfun,
1230 struct lcrecord_header *header = (struct lcrecord_header *)XPNTR(obj);
1233 error("printing unreadable object #<%s 0x%x>",
1234 LHEADER_IMPLEMENTATION(&header->lheader)->name,
1237 write_fmt_string(printcharfun, "#<%s 0x%x>",
1238 LHEADER_IMPLEMENTATION(&header->lheader)->name, header->uid);
1242 internal_object_printer(Lisp_Object obj, Lisp_Object printcharfun,
1245 write_fmt_string(printcharfun, "#<INTERNAL OBJECT (SXEmacs bug?) (%s) 0x%lx>",
1246 XRECORD_LHEADER_IMPLEMENTATION(obj)->name,
1247 (unsigned long)XPNTR(obj));
1250 enum printing_badness {
1251 BADNESS_INTEGER_OBJECT,
1252 BADNESS_POINTER_OBJECT,
1257 printing_major_badness(Lisp_Object printcharfun,
1258 Char_ASCII * badness_string, int type, void *val,
1259 enum printing_badness badness)
1265 case BADNESS_INTEGER_OBJECT:
1266 len = snprintf(buf, sizeof(buf), "%s %d object %ld", badness_string, type,
1270 case BADNESS_POINTER_OBJECT:
1271 len = snprintf(buf, sizeof(buf), "%s %d object %p", badness_string, type, val);
1274 case BADNESS_NO_TYPE:
1275 len = snprintf(buf, sizeof(buf), "%s object %p", badness_string, val);
1278 len = snprintf(buf, sizeof(buf), "%s unknown badness %d",
1279 badness_string, badness);
1282 assert(len >= 0 && (size_t)len < sizeof(buf));
1284 /* Don't abort or signal if called from debug_print() or already
1286 if (!inhibit_non_essential_printing_operations) {
1287 #ifdef ERROR_CHECK_TYPES
1289 #else /* not ERROR_CHECK_TYPES */
1291 type_error(Qinternal_error, "printing %s", buf);
1292 #endif /* not ERROR_CHECK_TYPES */
1294 write_fmt_string(printcharfun,
1295 "#<EMACS BUG: %s Save your buffers immediately and "
1296 "please report this bug>", buf);
1300 print_internal(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1302 /* This function can GC */
1303 /* defined in emacs.c */
1304 extern int inhibit_autoloads, nodumpfile;
1308 /* Emacs won't print while GCing, but an external debugger might */
1313 /* #### Both input and output streams should have a flag associated
1314 with them indicating whether output to that stream, or strings
1315 read from the stream, get translated using Fgettext(). Such a
1316 stream is called a "translating stream". For the minibuffer and
1317 external-debugging-output this is always true on output, and
1318 with-output-to-temp-buffer sets the flag to true for the buffer
1319 it creates. This flag should also be user-settable. Perhaps it
1320 should be split up into two flags, one for input and one for
1324 /* Try out custom printing */
1325 if (UNLIKELY(!(bool)inhibit_autoloads && !(bool)nodumpfile) &&
1326 !EQ(Qnil, Vcustom_object_printer) &&
1327 !EQ(Qnil, apply1(Vcustom_object_printer,
1328 Fcons(obj, Fcons(printcharfun, Qnil))))) {
1332 /* Detect circularities and truncate them.
1333 No need to offer any alternative--this is better than an error. */
1334 if (CONSP(obj) || VECTORP(obj) || COMPILED_FUNCTIONP(obj)) {
1336 for (i = 0; i < print_depth; i++)
1337 if (EQ(obj, being_printed[i])) {
1340 long_to_string(buf + 1, i, sizeof(buf)-1);
1341 write_c_string(buf, printcharfun);
1346 being_printed[print_depth] = obj;
1349 if (print_depth > PRINT_CIRCLE) {
1350 error("Apparently circular structure being printed");
1353 switch (XTYPE(obj)) {
1354 case Lisp_Type_Int_Even:
1355 case Lisp_Type_Int_Odd: {
1356 /* ASCII Decimal representation uses 2.4 times as many bits as
1358 char buf[3 * sizeof(EMACS_INT) + 5];
1359 long_to_string(buf, XINT(obj),sizeof(buf));
1360 write_c_string(buf, printcharfun);
1364 case Lisp_Type_Char: {
1365 /* God intended that this be #\..., you know. */
1367 memset(buf, 0, sizeof(buf));
1368 Emchar ch = XCHAR(obj);
1386 if ((ch + 64) == '\\')
1390 } else if (ch < 127) {
1391 /* syntactically special characters should be
1413 } else if (ch == 127) {
1414 *p++ = '\\', *p++ = '^', *p++ = '?';
1415 } else if (ch < 160) {
1416 *p++ = '\\', *p++ = '^';
1417 p += set_charptr_emchar((Bufbyte *) p, ch + 64);
1419 p += set_charptr_emchar((Bufbyte *) p, ch);
1422 output_string(printcharfun, (Bufbyte *) buf, Qnil, 0,
1428 case Lisp_Type_Record: {
1429 struct lrecord_header *lheader = XRECORD_LHEADER(obj);
1431 /* Try to check for various sorts of bogus pointers if we're in
1432 a situation where it may be likely -- i.e. called from
1433 debug_print() or we're already crashing. In such cases,
1434 (further) crashing is counterproductive. */
1436 if (inhibit_non_essential_printing_operations &&
1437 !debug_can_access_memory(lheader, sizeof(*lheader))) {
1438 write_fmt_string(printcharfun,
1439 "#<EMACS BUG: BAD MEMORY ACCESS %p>",
1444 if (CONSP(obj) || VECTORP(obj)) {
1445 /* If deeper than spec'd depth, print placeholder. */
1446 if (INTP(Vprint_level)
1447 && print_depth > XINT(Vprint_level)) {
1448 write_c_string("...", printcharfun);
1453 if (lheader->type == lrecord_type_free) {
1454 printing_major_badness(printcharfun,
1459 } else if (lheader->type == lrecord_type_undefined) {
1460 printing_major_badness(printcharfun,
1461 "lrecord_type_undefined",
1465 } else if (lheader->type >= lrecord_type_count) {
1466 printing_major_badness(printcharfun,
1467 "illegal lrecord type",
1468 (int)(lheader->type),
1470 BADNESS_POINTER_OBJECT);
1474 /* Further checks for bad memory in critical situations. We
1475 don't normally do these because they may be expensive or
1476 weird (e.g. under Unix we typically have to set a SIGSEGV
1477 handler and try to trigger a seg fault). */
1479 if (inhibit_non_essential_printing_operations) {
1480 const struct lrecord_implementation *imp =
1481 LHEADER_IMPLEMENTATION(lheader);
1483 if (!debug_can_access_memory
1484 (lheader, imp->size_in_bytes_method ?
1485 imp->size_in_bytes_method(lheader) :
1486 imp->static_size)) {
1489 "#<EMACS BUG: type %s "
1490 "BAD MEMORY ACCESS %p>",
1491 LHEADER_IMPLEMENTATION
1492 (lheader)->name, lheader);
1497 Lisp_String *l = (Lisp_String *)lheader;
1498 if (!debug_can_access_memory(
1499 l->data, l->size)) {
1503 "(CAN'T ACCESS STRING "
1504 "DATA %p)>", lheader, l->data);
1510 if (LHEADER_IMPLEMENTATION(lheader)->printer) {
1511 ((LHEADER_IMPLEMENTATION(lheader)->printer)
1512 (obj, printcharfun, escapeflag));
1514 default_object_printer(obj, printcharfun, escapeflag);
1520 /* We're in trouble if this happens! */
1521 printing_major_badness(printcharfun,
1522 "illegal data type", XTYPE(obj),
1524 BADNESS_INTEGER_OBJECT);
1533 void print_symbol(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1535 /* This function can GC */
1536 /* #### Bug!! (intern "") isn't printed in some distinguished way */
1537 /* #### (the reader also loses on it) */
1538 Lisp_String *name = symbol_name(XSYMBOL(obj));
1539 Bytecount size = string_length(name);
1540 struct gcpro gcpro1, gcpro2;
1543 /* This deals with GC-relocation */
1544 Lisp_Object nameobj;
1545 XSETSTRING(nameobj, name);
1546 output_string(printcharfun, 0, nameobj, 0, size);
1549 GCPRO2(obj, printcharfun);
1551 /* If we print an uninterned symbol as part of a complex object and
1552 the flag print-gensym is non-nil, prefix it with #n= to read the
1553 object back with the #n# reader syntax later if needed. */
1554 if (!NILP(Vprint_gensym)
1555 /* #### Test whether this produces a noticeable slow-down for
1556 printing when print-gensym is non-nil. */
1557 && !EQ(obj, oblookup(Vobarray,
1558 string_data(symbol_name(XSYMBOL(obj))),
1559 string_length(symbol_name(XSYMBOL(obj)))))) {
1560 if (print_depth > 1) {
1561 Lisp_Object tem = Fassq(obj, Vprint_gensym_alist);
1563 write_char_internal("#", printcharfun);
1564 print_internal(XCDR(tem), printcharfun,
1566 write_char_internal("#", printcharfun);
1570 if (CONSP(Vprint_gensym_alist)) {
1571 /* Vprint_gensym_alist is exposed to Lisp, so we
1572 have to be careful. */
1573 CHECK_CONS(XCAR(Vprint_gensym_alist));
1575 (XCAR(Vprint_gensym_alist)));
1579 (Vprint_gensym_alist))) +
1583 Vprint_gensym_alist =
1584 Fcons(Fcons(obj, tem), Vprint_gensym_alist);
1586 write_char_internal("#", printcharfun);
1587 print_internal(tem, printcharfun, escapeflag);
1588 write_char_internal("=", printcharfun);
1591 write_c_string("#:", printcharfun);
1594 /* Does it look like an integer or a float? */
1596 Bufbyte *data = string_data(name);
1597 Bytecount confusing = 0;
1600 goto not_yet_confused; /* Really confusing */
1601 else if (isdigit(data[0]))
1604 goto not_yet_confused;
1605 else if (data[0] == '-' || data[0] == '+')
1608 goto not_yet_confused;
1610 for (; confusing < size; confusing++) {
1611 if (!isdigit(data[confusing])) {
1620 /* #### Ugh, this is needlessly complex and slow for what we
1621 need here. It might be a good idea to copy equivalent code
1622 from FSF. --hniksic */
1623 confusing = isfloat_string((char *)data);
1626 write_char_internal("\\", printcharfun);
1630 Lisp_Object nameobj;
1634 XSETSTRING(nameobj, name);
1635 for (i = 0; i < size; i++) {
1636 switch (string_byte(name, i)) {
1684 output_string(printcharfun, 0, nameobj,
1686 write_char_internal("\\", printcharfun);
1692 output_string(printcharfun, 0, nameobj, last, size - last);
1697 /* Useful on systems or in places where writing to stdout is unavailable or
1700 static int alternate_do_pointer;
1701 static char alternate_do_string[5000];
1703 DEFUN("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0, /*
1704 Append CHARACTER to the array `alternate_do_string'.
1705 This can be used in place of `external-debugging-output' as a function
1706 to be passed to `print'. Before calling `print', set `alternate_do_pointer'
1711 Bufbyte str[MAX_EMCHAR_LEN];
1714 const Extbyte *extptr = NULL;
1716 CHECK_CHAR_COERCE_INT(character);
1717 len = set_charptr_emchar(str, XCHAR(character));
1718 TO_EXTERNAL_FORMAT(DATA, (str, len),
1719 ALLOCA, (extptr, extlen), Qterminal);
1720 if ( extptr != NULL ) {
1721 memcpy(alternate_do_string + alternate_do_pointer, extptr, extlen);
1722 alternate_do_pointer += extlen;
1723 alternate_do_string[alternate_do_pointer] = 0;
1725 /* Better bad transcoding than nothing I guess... */
1726 memcpy(alternate_do_string + alternate_do_pointer, str, len);
1727 alternate_do_pointer += len;
1728 alternate_do_string[alternate_do_pointer] = 0;
1733 DEFUN("external-debugging-output", Fexternal_debugging_output, 1, 3, 0, /*
1734 Write CHAR-OR-STRING to stderr or stdout.
1735 If optional arg STDOUT-P is non-nil, write to stdout; otherwise, write
1736 to stderr. You can use this function to write directly to the terminal.
1737 This function can be used as the STREAM argument of Fprint() or the like.
1739 Under MS Windows, this writes output to the console window (which is
1740 created, if necessary), unless SXEmacs is being run noninteractively
1741 \(i.e. using the `-batch' argument).
1743 If you have opened a termscript file (using `open-termscript'), then
1744 the output also will be logged to this file.
1746 (char_or_string, stdout_p, device))
1749 struct console *con = NULL;
1752 if (!NILP(stdout_p))
1757 CHECK_LIVE_DEVICE(device);
1758 if (!DEVICE_TTY_P(XDEVICE(device)) &&
1759 !DEVICE_STREAM_P(XDEVICE(device)))
1760 signal_simple_error("Must be tty or stream device",
1762 con = XCONSOLE(DEVICE_CONSOLE(XDEVICE(device)));
1763 if (DEVICE_TTY_P(XDEVICE(device))) {
1765 } else if (!NILP(stdout_p)) {
1766 file = CONSOLE_STREAM_DATA(con)->out;
1768 file = CONSOLE_STREAM_DATA(con)->err;
1772 if (STRINGP(char_or_string))
1773 write_string_to_stdio_stream(file, con,
1774 XSTRING_DATA(char_or_string),
1775 0, XSTRING_LENGTH(char_or_string),
1778 Bufbyte str[MAX_EMCHAR_LEN];
1781 CHECK_CHAR_COERCE_INT(char_or_string);
1782 len = set_charptr_emchar(str, XCHAR(char_or_string));
1783 write_string_to_stdio_stream(file, con, str, 0, len, Qterminal,
1787 return char_or_string;
1790 DEFUN("open-termscript", Fopen_termscript, 1, 1, "FOpen termscript file: ", /*
1791 Start writing all terminal output to FILENAME as well as the terminal.
1792 FILENAME = nil means just close any termscript file currently open.
1796 /* This function can GC */
1797 if (termscript != 0) {
1802 if (!NILP(filename)) {
1803 filename = Fexpand_file_name(filename, Qnil);
1804 termscript = fopen((char *)XSTRING_DATA(filename), "w");
1805 if (termscript == NULL)
1806 report_file_error("Opening termscript",
1813 /* Debugging kludge -- unbuffered */
1814 static int debug_print_length = 50;
1815 static int debug_print_level = 15;
1816 static int debug_print_readably = -1;
1818 static void debug_print_no_newline(Lisp_Object debug_print_obj)
1820 /* This function can GC */
1821 int save_print_readably = print_readably;
1822 int save_print_depth = print_depth;
1823 Lisp_Object save_Vprint_length = Vprint_length;
1824 Lisp_Object save_Vprint_level = Vprint_level;
1825 Lisp_Object save_Vinhibit_quit = Vinhibit_quit;
1826 struct gcpro gcpro1, gcpro2, gcpro3;
1827 GCPRO3(save_Vprint_level, save_Vprint_length, save_Vinhibit_quit);
1831 ("** gc-in-progress! Bad idea to print anything! **\n");
1834 print_readably = debug_print_readably != -1 ? debug_print_readably : 0;
1836 inhibit_non_essential_printing_operations = 1;
1837 /* Could use unwind-protect, but why bother? */
1838 if (debug_print_length > 0)
1839 Vprint_length = make_int(debug_print_length);
1840 if (debug_print_level > 0)
1841 Vprint_level = make_int(debug_print_level);
1843 print_internal(debug_print_obj, Qexternal_debugging_output, 1);
1844 alternate_do_pointer = 0;
1845 print_internal(debug_print_obj, Qalternate_debugging_output, 1);
1847 Vinhibit_quit = save_Vinhibit_quit;
1848 Vprint_level = save_Vprint_level;
1849 Vprint_length = save_Vprint_length;
1850 print_depth = save_print_depth;
1851 print_readably = save_print_readably;
1852 inhibit_non_essential_printing_operations = 0;
1857 void debug_print(Lisp_Object debug_print_obj)
1859 debug_print_no_newline(debug_print_obj);
1863 /* Debugging kludge -- unbuffered */
1864 /* This function provided for the benefit of the debugger. */
1865 void debug_backtrace(void)
1867 /* This function can GC */
1868 int old_print_readably = print_readably;
1869 int old_print_depth = print_depth;
1870 Lisp_Object old_print_length = Vprint_length;
1871 Lisp_Object old_print_level = Vprint_level;
1872 Lisp_Object old_inhibit_quit = Vinhibit_quit;
1874 struct gcpro gcpro1, gcpro2, gcpro3;
1875 GCPRO3(old_print_level, old_print_length, old_inhibit_quit);
1879 ("** gc-in-progress! Bad idea to print anything! **\n");
1884 inhibit_non_essential_printing_operations = 1;
1885 /* Could use unwind-protect, but why bother? */
1886 if (debug_print_length > 0)
1887 Vprint_length = make_int(debug_print_length);
1888 if (debug_print_level > 0)
1889 Vprint_level = make_int(debug_print_level);
1891 Fbacktrace(Qexternal_debugging_output, Qt);
1894 Vinhibit_quit = old_inhibit_quit;
1895 Vprint_level = old_print_level;
1896 Vprint_length = old_print_length;
1897 print_depth = old_print_depth;
1898 print_readably = old_print_readably;
1899 inhibit_non_essential_printing_operations = 0;
1905 void debug_short_backtrace(int length)
1908 struct backtrace *bt = backtrace_list;
1910 while (length > 0 && bt) {
1914 if (COMPILED_FUNCTIONP(*bt->function)) {
1915 #if defined(COMPILED_FUNCTION_ANNOTATION_HACK)
1917 compiled_function_annotation(XCOMPILED_FUNCTION
1920 Lisp_Object ann = Qnil;
1923 stderr_out("<compiled-function from ");
1924 debug_print_no_newline(ann);
1928 ("<compiled-function of unknown origin>");
1931 debug_print_no_newline(*bt->function);
1939 #endif /* debugging kludge */
1941 void syms_of_print(void)
1943 defsymbol(&Qstandard_output, "standard-output");
1945 defsymbol(&Qprint_length, "print-length");
1947 defsymbol(&Qprint_string_length, "print-string-length");
1949 defsymbol(&Qdisplay_error, "display-error");
1950 defsymbol(&Qprint_message_label, "print-message-label");
1953 DEFSUBR(Fprin1_to_string);
1956 DEFSUBR(Ferror_message_string);
1957 DEFSUBR(Fdisplay_error);
1959 DEFSUBR(Fwrite_char);
1960 DEFSUBR(Falternate_debugging_output);
1961 DEFSUBR(Fexternal_debugging_output);
1962 DEFSUBR(Fopen_termscript);
1963 defsymbol(&Qexternal_debugging_output, "external-debugging-output");
1964 defsymbol(&Qalternate_debugging_output, "alternate-debugging-output");
1965 DEFSUBR(Fwith_output_to_temp_buffer);
1968 void reinit_vars_of_print(void)
1970 alternate_do_pointer = 0;
1973 void vars_of_print(void)
1975 reinit_vars_of_print();
1977 DEFVAR_LISP("standard-output", &Vstandard_output /*
1978 Output stream `print' uses by default for outputting a character.
1979 This may be any function of one argument.
1980 It may also be a buffer (output is inserted before point)
1981 or a marker (output is inserted and the marker is advanced)
1982 or the symbol t (output appears in the minibuffer line).
1984 Vstandard_output = Qt;
1987 DEFVAR_LISP("float-output-format", &Vfloat_output_format /*
1988 The format descriptor string that lisp uses to print floats.
1989 This is a %-spec like those accepted by `printf' in C,
1990 but with some restrictions. It must start with the two characters `%.'.
1991 After that comes an integer precision specification,
1992 and then a letter which controls the format.
1993 The letters allowed are `e', `f' and `g'.
1994 Use `e' for exponential notation "DIG.DIGITSeEXPT"
1995 Use `f' for decimal point notation "DIGITS.DIGITS".
1996 Use `g' to choose the shorter of those two formats for the number at hand.
1997 The precision in any of these cases is the number of digits following
1998 the decimal point. With `f', a precision of 0 means to omit the
1999 decimal point. 0 is not allowed with `f' or `g'.
2001 A value of nil means to use `%.16g'.
2003 Regardless of the value of `float-output-format', a floating point number
2004 will never be printed in such a way that it is ambiguous with an integer;
2005 that is, a floating-point number will always be printed with a decimal
2006 point and/or an exponent, even if the digits following the decimal point
2007 are all zero. This is to preserve read-equivalence.
2009 Vfloat_output_format = Qnil;
2010 #endif /* HAVE_FPFLOAT */
2012 DEFVAR_LISP("print-length", &Vprint_length /*
2013 Maximum length of list or vector to print before abbreviating.
2014 A value of nil means no limit.
2016 Vprint_length = Qnil;
2018 DEFVAR_LISP("print-string-length", &Vprint_string_length /*
2019 Maximum length of string to print before abbreviating.
2020 A value of nil means no limit.
2022 Vprint_string_length = Qnil;
2024 DEFVAR_LISP("print-level", &Vprint_level /*
2025 Maximum depth of list nesting to print before abbreviating.
2026 A value of nil means no limit.
2028 Vprint_level = Qnil;
2030 DEFVAR_BOOL("print-escape-newlines", &print_escape_newlines /*
2031 Non-nil means print newlines in strings as backslash-n.
2033 print_escape_newlines = 0;
2035 DEFVAR_BOOL("print-readably", &print_readably /*
2036 If non-nil, then all objects will be printed in a readable form.
2037 If an object has no readable representation, then an error is signalled.
2038 When print-readably is true, compiled-function objects will be written in
2039 #[...] form instead of in #<compiled-function [...]> form, and two-element
2040 lists of the form (quote object) will be written as the equivalent 'object.
2041 Do not SET this variable; bind it instead.
2045 /* #### I think this should default to t. But we'd better wait
2046 until we see that it works out. */
2047 DEFVAR_LISP("print-gensym", &Vprint_gensym /*
2048 If non-nil, then uninterned symbols will be printed specially.
2049 Uninterned symbols are those which are not present in `obarray', that is,
2050 those which were made with `make-symbol' or by calling `intern' with a
2053 When print-gensym is true, such symbols will be preceded by "#:",
2054 which causes the reader to create a new symbol instead of interning
2055 and returning an existing one. Beware: the #: syntax creates a new
2056 symbol each time it is seen, so if you print an object which contains
2057 two pointers to the same uninterned symbol, `read' will not duplicate
2060 If the value of `print-gensym' is a cons cell, then in addition
2061 refrain from clearing `print-gensym-alist' on entry to and exit from
2062 printing functions, so that the use of #...# and #...= can carry over
2063 for several separately printed objects.
2065 Vprint_gensym = Qnil;
2067 DEFVAR_LISP("print-gensym-alist", &Vprint_gensym_alist /*
2068 Association list of elements (GENSYM . N) to guide use of #N# and #N=.
2069 In each element, GENSYM is an uninterned symbol that has been associated
2070 with #N= for the specified value of N.
2072 Vprint_gensym_alist = Qnil;
2074 DEFVAR_LISP("print-message-label", &Vprint_message_label /*
2075 Label for minibuffer messages created with `print'. This should
2076 generally be bound with `let' rather than set. (See `display-message'.)
2078 Vprint_message_label = Qprint;
2080 DEFVAR_LISP("custom-object-printer", &Vcustom_object_printer /*
2081 Function to call in order to print custom object.
2083 Vcustom_object_printer = Qnil;