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;
107 std_handle_out_external(FILE * stream, Lisp_Object lstream,
108 const Extbyte * extptr, Extcount extlen,
109 /* is this really stdout/stderr?
110 (controls termscript writing) */
111 int output_is_std_handle, int must_flush)
113 assert(extptr != NULL);
116 stdout_needs_newline = 1;
120 fwrite(extptr, 1, extlen, stream);
121 if (must_flush) fflush(stream);
123 Lstream_write(XLSTREAM(lstream), extptr, extlen);
125 if (output_is_std_handle) {
127 fwrite(extptr, 1, extlen, termscript);
130 stdout_needs_newline = extptr[extlen - 1] != '\n';
135 #define SXE_VSNPRINT_VA(ret,sbuf,buf,size,spec,tries,type,fmt,args) \
138 ret = vsnprintf((char*)buf,size,fmt,args); \
139 if ( retval == 0 ) { \
140 /* Nothing to write */ \
142 } else if ( ret < 0 ) { \
143 XMALLOC_UNBIND(buf,size,spec); \
145 XMALLOC_OR_ALLOCA(buf,size,type); \
147 } else if ( ret > size ) { \
148 /* We need more space, so we need to allocate it */ \
149 XMALLOC_UNBIND(buf,size,spec); \
151 XMALLOC_OR_ALLOCA(buf,size,type); \
154 } while( ret == 0 && tries > 0 )
157 int write_fmt_str(Lisp_Object stream, const char* fmt, ...)
161 int bufsize, retval, tries = 3;
162 /* write_fmt_str is used for small prints usually... */
164 int speccount = specpdl_depth();
168 bufsize = sizeof(buffer);
170 SXE_VSNPRINT_VA(retval,buffer,kludge,bufsize,speccount,tries,char,fmt,args);
173 write_c_string(kludge,stream);
175 XMALLOC_UNBIND(kludge, bufsize, speccount);
179 error("Error attempting to write write format string '%s'",
184 int write_fmt_string(Lisp_Object stream, const char *fmt, ...)
188 int bufsize, retval, tries = 3;
189 /* write_va is used for small prints usually... */
191 int speccount = specpdl_depth();
195 bufsize = sizeof(buffer);
197 SXE_VSNPRINT_VA(retval,buffer,kludge,bufsize,speccount,tries,char,fmt,args);
199 write_c_string(kludge,stream);
200 XMALLOC_UNBIND(kludge, bufsize, speccount);
204 error("Error attempting to write write format string '%s'",
209 /* #### The following function should be replaced a call to the
210 emacs_doprnt_*() functions. This is the only way to ensure that
211 I18N3 works properly (many implementations of the *printf()
212 functions, including the ones included in glibc, do not implement
213 the %###$ argument-positioning syntax).
215 Note, however, that to do this, we'd have to
217 1) pre-allocate all the lstreams and do whatever else was necessary
218 to make sure that no allocation occurs, since these functions may be
219 called from fatal_error_signal().
221 2) (to be really correct) make a new lstream that outputs using
222 mswindows_output_console_string(). */
224 static int std_handle_out_va(FILE * stream, const char *fmt, va_list args)
226 int retval, tries = 3;
230 Bufbyte buffer[1024]; /* Tax stack lightly, used to be 16KiB */
231 int speccount = specpdl_depth();
233 bufsize = sizeof(buffer);
236 SXE_VSNPRINT_VA(retval,buffer,kludge,bufsize,speccount,tries,Bufbyte,fmt,args);
239 /* nothing to write */
242 use_fprintf = ! initialized ||fatal_error_in_progress ||
243 inhibit_non_essential_printing_operations;
247 fprintf(stream,"%s",(char*)kludge);
249 Extbyte *extptr = NULL;
250 Extcount extlen = retval;
252 TO_EXTERNAL_FORMAT(DATA, (kludge, strlen((char *)kludge)),
253 ALLOCA, (extptr, extlen), Qnative);
254 std_handle_out_external(stream, Qnil, extptr, extlen, 1, 1);
258 fprintf(stream,"Error attempting to write format string '%s'",
261 const Extbyte *msg = "Error attempting to write format string";
262 std_handle_out_external(stream, Qnil, msg, strlen(msg), 1, 1);
265 XMALLOC_UNBIND(kludge, bufsize, speccount);
270 /* Output portably to stderr or its equivalent; call GETTEXT on the
271 format string. Automatically flush when done. */
273 int stderr_out(const char *fmt, ...)
281 && !fatal_error_in_progress ? GETTEXT(fmt) : fmt, args);
286 /* Output portably to stdout or its equivalent; call GETTEXT on the
287 format string. Automatically flush when done. */
289 int stdout_out(const char *fmt, ...)
294 retval = std_handle_out_va(stdout,
295 (initialized && !fatal_error_in_progress
296 ? GETTEXT(fmt) : fmt),
302 DOESNT_RETURN fatal(const char *fmt, ...)
307 stderr_out("\nSXEmacs: ");
308 std_handle_out_va(stderr,
309 (initialized && !fatal_error_in_progress
310 ? GETTEXT(fmt) : fmt),
318 /* Write a string (in internal format) to stdio stream STREAM. */
321 write_string_to_stdio_stream(FILE * stream, struct console *con,
323 Bytecount offset, Bytecount len,
324 Lisp_Object coding_system, int must_flush)
327 const Extbyte *extptr;
329 /* #### yuck! sometimes this function is called with string data,
330 and the following call may gc. */
332 Bufbyte *puta = (Bufbyte *) alloca(len);
333 memcpy(puta, str + offset, len);
335 if (initialized && !inhibit_non_essential_printing_operations)
336 TO_EXTERNAL_FORMAT(DATA, (puta, len),
337 ALLOCA, (extptr, extlen),
340 extptr = (Extbyte *) puta;
341 extlen = (Bytecount) len;
346 std_handle_out_external(stream, Qnil, extptr, extlen,
348 || stream == stderr, must_flush);
350 assert(CONSOLE_TTY_P(con));
351 std_handle_out_external(0, CONSOLE_TTY_DATA(con)->outstream,
353 CONSOLE_TTY_DATA(con)->is_stdio,
358 /* Write a string to the output location specified in FUNCTION.
359 Arguments NONRELOC, RELOC, OFFSET, and LEN are as in
360 buffer_insert_string_1() in insdel.c. */
363 output_string(Lisp_Object function, const Bufbyte * nonreloc,
364 Lisp_Object reloc, Bytecount offset, Bytecount len)
366 /* This function can GC */
368 /* We change the value of nonreloc (fetching it from reloc as
369 necessary), but we don't want to pass this changed value on to
370 other functions that take both a nonreloc and a reloc, or things
371 may get confused and an assertion failure in
372 fixup_internal_substring() may get triggered. */
373 const Bufbyte *newnonreloc = nonreloc;
374 struct gcpro gcpro1, gcpro2;
376 /* Emacs won't print while GCing, but an external debugger might */
380 /* Perhaps not necessary but probably safer. */
381 GCPRO2(function, reloc);
383 fixup_internal_substring(newnonreloc, reloc, offset, &len);
386 newnonreloc = XSTRING_DATA(reloc);
388 cclen = bytecount_to_charcount(newnonreloc + offset, len);
390 if (LSTREAMP(function)) {
391 if (STRINGP(reloc)) {
392 /* Protect against Lstream_write() causing a GC and
393 relocating the string. For small strings, we do it by
394 alloc'ing the string and using a copy; for large strings,
397 Bufbyte *copied = alloca_array(Bufbyte, len);
398 memcpy(copied, newnonreloc + offset, len);
399 Lstream_write(XLSTREAM(function), copied, len);
401 int speccount = specpdl_depth();
402 record_unwind_protect(restore_gc_inhibit,
404 (gc_currently_forbidden));
405 gc_currently_forbidden = 1;
406 Lstream_write(XLSTREAM(function),
407 newnonreloc + offset, len);
408 unbind_to(speccount, Qnil);
411 Lstream_write(XLSTREAM(function), newnonreloc + offset,
414 if (print_unbuffered)
415 Lstream_flush(XLSTREAM(function));
416 } else if (BUFFERP(function)) {
417 CHECK_LIVE_BUFFER(function);
418 buffer_insert_string(XBUFFER(function), nonreloc, reloc, offset,
420 } else if (MARKERP(function)) {
421 /* marker_position() will err if marker doesn't point anywhere. */
422 Bufpos spoint = marker_position(function);
424 buffer_insert_string_1(XMARKER(function)->buffer,
425 spoint, nonreloc, reloc, offset, len, 0);
426 Fset_marker(function, make_int(spoint + cclen),
427 Fmarker_buffer(function));
428 } else if (FRAMEP(function)) {
429 /* This gets used by functions not invoking print_prepare(),
430 such as Fwrite_char, Fterpri, etc.. */
431 struct frame *f = XFRAME(function);
432 CHECK_LIVE_FRAME(function);
434 if (!EQ(Vprint_message_label, echo_area_status(f)))
435 clear_echo_area_from_print(f, Qnil, 1);
436 echo_area_append(f, nonreloc, reloc, offset, len,
437 Vprint_message_label);
438 } else if (EQ(function, Qt) || EQ(function, Qnil)) {
439 write_string_to_stdio_stream(stdout, 0, newnonreloc, offset,
440 len, Qterminal, print_unbuffered);
442 Charcount ccoff = bytecount_to_charcount(newnonreloc, offset);
445 for (iii = ccoff; iii < cclen + ccoff; iii++) {
447 make_char(charptr_emchar_n(newnonreloc, iii)));
449 newnonreloc = XSTRING_DATA(reloc);
456 #define RESET_PRINT_GENSYM do { \
457 if (!CONSP (Vprint_gensym)) \
458 Vprint_gensym_alist = Qnil; \
461 static Lisp_Object canonicalize_printcharfun(Lisp_Object printcharfun)
463 if (NILP(printcharfun))
464 printcharfun = Vstandard_output;
466 if (EQ(printcharfun, Qt) || NILP(printcharfun))
467 printcharfun = Fselected_frame(Qnil); /* print to minibuffer */
473 print_prepare(Lisp_Object printcharfun, Lisp_Object * frame_kludge)
475 /* Emacs won't print while GCing, but an external debugger might */
481 printcharfun = canonicalize_printcharfun(printcharfun);
483 /* Here we could safely return the canonicalized PRINTCHARFUN.
484 However, if PRINTCHARFUN is a frame, printing of complex
485 structures becomes very expensive, because `append-message'
486 (called by echo_area_append) gets called as many times as
487 output_string() is called (and that's a *lot*). append-message
488 tries to keep top of the message-stack in sync with the contents
489 of " *Echo Area" buffer, consing a new string for each component
490 of the printed structure. For instance, if you print (a a),
491 append-message will cons up the following strings:
499 and will use only the last one. With larger objects, this turns
500 into an O(n^2) consing frenzy that locks up SXEmacs in incessant
503 We prevent this by creating a resizing_buffer stream and letting
504 the printer write into it. print_finish() will notice this
505 stream, and invoke echo_area_append() with the stream's buffer,
507 if (FRAMEP(printcharfun)) {
508 CHECK_LIVE_FRAME(printcharfun);
509 *frame_kludge = printcharfun;
510 printcharfun = make_resizing_buffer_output_stream();
516 static void print_finish(Lisp_Object stream, Lisp_Object frame_kludge)
518 /* Emacs won't print while GCing, but an external debugger might */
524 /* See the comment in print_prepare(). */
525 if (FRAMEP(frame_kludge)) {
526 struct frame *f = XFRAME(frame_kludge);
527 Lstream *str = XLSTREAM(stream);
528 CHECK_LIVE_FRAME(frame_kludge);
531 if (!EQ(Vprint_message_label, echo_area_status(f)))
532 clear_echo_area_from_print(f, Qnil, 1);
533 echo_area_append(f, resizing_buffer_stream_ptr(str),
534 Qnil, 0, Lstream_byte_count(str),
535 Vprint_message_label);
540 /* Used for printing a single-byte character (*not* any Emchar). */
541 #define write_char_internal(string_of_length_1, stream) \
542 output_string (stream, (const Bufbyte *) (string_of_length_1), \
545 /* NOTE: Do not call this with the data of a Lisp_String, as
546 printcharfun might cause a GC, which might cause the string's data
547 to be relocated. To princ a Lisp string, use:
549 print_internal (string, printcharfun, 0);
551 Also note that STREAM should be the result of
552 canonicalize_printcharfun() (i.e. Qnil means stdout, not
553 Vstandard_output, etc.) */
554 void write_string_1(const Bufbyte * str, Bytecount size, Lisp_Object stream)
556 /* This function can GC */
557 #ifdef ERROR_CHECK_BUFPOS
560 output_string(stream, str, Qnil, 0, size);
564 void write_hex_ptr(void* value, Lisp_Object stream)
566 char buf[sizeof(value)*2+1];
567 int n = snprintf(buf,sizeof(buf),"0x%p",value);
568 assert(n>=0 && n<sizeof(buf));
569 write_c_string(buf,stream);
572 void write_c_string(const char *str, Lisp_Object stream)
574 /* This function can GC */
575 write_string_1((const Bufbyte *)str, strlen(str), stream);
579 DEFUN("write-char", Fwrite_char, 1, 2, 0, /*
580 Output character CHARACTER to stream STREAM.
581 STREAM defaults to the value of `standard-output' (which see).
585 /* This function can GC */
586 Bufbyte str[MAX_EMCHAR_LEN];
589 CHECK_CHAR_COERCE_INT(character);
590 len = set_charptr_emchar(str, XCHAR(character));
591 output_string(canonicalize_printcharfun(stream), str, Qnil, 0, len);
595 void temp_output_buffer_setup(Lisp_Object bufname)
597 /* This function can GC */
598 struct buffer *old = current_buffer;
602 /* #### This function should accept a Lisp_Object instead of a char *,
603 so that proper translation on the buffer name can occur. */
606 Fset_buffer(Fget_buffer_create(bufname));
608 current_buffer->read_only = Qnil;
611 XSETBUFFER(buf, current_buffer);
612 specbind(Qstandard_output, buf);
614 set_buffer_internal(old);
618 internal_with_output_to_temp_buffer(Lisp_Object bufname,
619 Lisp_Object(*function) (Lisp_Object arg),
620 Lisp_Object arg, Lisp_Object same_frame)
622 int speccount = specpdl_depth();
623 struct gcpro gcpro1, gcpro2, gcpro3;
624 Lisp_Object buf = Qnil;
626 GCPRO3(buf, arg, same_frame);
628 temp_output_buffer_setup(bufname);
629 buf = Vstandard_output;
631 arg = (*function) (arg);
633 temp_output_buffer_show(buf, same_frame);
636 return unbind_to(speccount, arg);
639 DEFUN("with-output-to-temp-buffer", Fwith_output_to_temp_buffer, 1, UNEVALLED, 0, /*
640 Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
641 The buffer is cleared out initially, and marked as unmodified when done.
642 All output done by BODY is inserted in that buffer by default.
643 The buffer is displayed in another window, but not selected.
644 The value of the last form in BODY is returned.
645 If BODY does not finish normally, the buffer BUFNAME is not displayed.
647 If variable `temp-buffer-show-function' is non-nil, call it at the end
648 to get the buffer displayed. It gets one argument, the buffer to display.
652 /* This function can GC */
653 Lisp_Object name = Qnil;
654 int speccount = specpdl_depth();
655 struct gcpro gcpro1, gcpro2;
656 Lisp_Object val = Qnil;
659 /* #### should set the buffer to be translating. See print_internal(). */
663 name = Feval(XCAR(args));
667 temp_output_buffer_setup(name);
670 val = Fprogn(XCDR(args));
672 temp_output_buffer_show(Vstandard_output, Qnil);
674 return unbind_to(speccount, val);
677 DEFUN("terpri", Fterpri, 0, 1, 0, /*
678 Output a newline to STREAM.
679 If STREAM is omitted or nil, the value of `standard-output' is used.
683 /* This function can GC */
684 write_char_internal("\n", canonicalize_printcharfun(stream));
688 DEFUN("prin1", Fprin1, 1, 2, 0, /*
689 Output the printed representation of OBJECT, any Lisp object.
690 Quoting characters are printed when needed to make output that `read'
691 can handle, whenever this is possible.
692 Output stream is STREAM, or value of `standard-output' (which see).
696 /* This function can GC */
697 Lisp_Object frame = Qnil;
698 struct gcpro gcpro1, gcpro2;
699 GCPRO2(object, stream);
702 stream = print_prepare(stream, &frame);
703 print_internal(object, stream, 1);
704 print_finish(stream, frame);
710 DEFUN("prin1-to-string", Fprin1_to_string, 1, 2, 0, /*
711 Return a string containing the printed representation of OBJECT,
712 any Lisp object. Quoting characters are used when needed to make output
713 that `read' can handle, whenever this is possible, unless the optional
714 second argument NOESCAPE is non-nil.
718 /* This function can GC */
719 Lisp_Object result = Qnil;
720 Lisp_Object stream = make_resizing_buffer_output_stream();
721 Lstream *str = XLSTREAM(stream);
722 /* gcpro OBJECT in case a caller forgot to do so */
723 struct gcpro gcpro1, gcpro2, gcpro3;
724 GCPRO3(object, stream, result);
728 print_internal(object, stream, NILP(noescape));
732 result = make_string(resizing_buffer_stream_ptr(str),
733 Lstream_byte_count(str));
738 DEFUN("princ", Fprinc, 1, 2, 0, /*
739 Output the printed representation of OBJECT, any Lisp object.
740 No quoting characters are used; no delimiters are printed around
741 the contents of strings.
742 Output stream is STREAM, or value of `standard-output' (which see).
746 /* This function can GC */
747 Lisp_Object frame = Qnil;
748 struct gcpro gcpro1, gcpro2;
750 GCPRO2(object, stream);
751 stream = print_prepare(stream, &frame);
753 print_internal(object, stream, 0);
754 print_finish(stream, frame);
759 DEFUN("print", Fprint, 1, 2, 0, /*
760 Output the printed representation of OBJECT, with newlines around it.
761 Quoting characters are printed when needed to make output that `read'
762 can handle, whenever this is possible.
763 Output stream is STREAM, or value of `standard-output' (which see).
767 /* This function can GC */
768 Lisp_Object frame = Qnil;
769 struct gcpro gcpro1, gcpro2;
771 GCPRO2(object, stream);
772 stream = print_prepare(stream, &frame);
774 write_char_internal("\n", stream);
775 print_internal(object, stream, 1);
776 write_char_internal("\n", stream);
777 print_finish(stream, frame);
782 /* Print an error message for the error DATA to STREAM. This is a
783 complete implementation of `display-error', which used to be in
784 Lisp (see prim/cmdloop.el). It was ported to C so it can be used
785 efficiently by Ferror_message_string. Fdisplay_error and
786 Ferror_message_string are trivial wrappers around this function.
788 STREAM should be the result of canonicalize_printcharfun(). */
790 print_error_message(Lisp_Object error_object, Lisp_Object stream)
792 /* This function can GC */
793 Lisp_Object type = Fcar_safe(error_object);
794 Lisp_Object method = Qnil;
797 /* No need to GCPRO anything under the assumption that ERROR_OBJECT
800 if (!(CONSP(error_object) && SYMBOLP(type))) {
801 Lisp_Object foo = Fget(type, Qerror_conditions, Qnil);
807 tail = XCDR(error_object);
808 while (!NILP(tail)) {
814 tail = Fget(type, Qerror_conditions, Qnil);
815 while (!NILP(tail)) {
816 if (!(CONSP(tail) && SYMBOLP(XCAR(tail))))
818 else if (!NILP(Fget(XCAR(tail), Qdisplay_error, Qnil))) {
819 method = Fget(XCAR(tail), Qdisplay_error, Qnil);
827 int speccount = specpdl_depth();
828 Lisp_Object frame = Qnil;
832 specbind(Qprint_message_label, Qerror);
833 stream = print_prepare(stream, &frame);
835 tail = Fcdr(error_object);
836 if (EQ(type, Qerror)) {
837 print_internal(Fcar(tail), stream, 0);
840 Lisp_Object errmsg = Fget(type, Qerror_message, Qnil);
842 print_internal(type, stream, 0);
844 print_internal(LISP_GETTEXT(errmsg), stream, 0);
846 while (!NILP(tail)) {
847 write_c_string(first ? ": " : ", ", stream);
848 print_internal(Fcar(tail), stream, 1);
852 print_finish(stream, frame);
854 unbind_to(speccount, Qnil);
861 write_c_string(GETTEXT("Peculiar error "), stream);
862 print_internal(error_object, stream, 1);
865 call2(method, error_object, stream);
869 DEFUN("error-message-string", Ferror_message_string, 1, 1, 0, /*
870 Convert ERROR-OBJECT to an error message, and return it.
872 The format of ERROR-OBJECT should be (ERROR-SYMBOL . DATA). The
873 message is equivalent to the one that would be issued by
874 `display-error' with the same argument.
878 /* This function can GC */
879 Lisp_Object result = Qnil;
880 Lisp_Object stream = make_resizing_buffer_output_stream();
884 print_error_message(error_object, stream);
885 Lstream_flush(XLSTREAM(stream));
886 result = make_string(resizing_buffer_stream_ptr(XLSTREAM(stream)),
887 Lstream_byte_count(XLSTREAM(stream)));
888 Lstream_delete(XLSTREAM(stream));
894 DEFUN("display-error", Fdisplay_error, 2, 2, 0, /*
895 Display ERROR-OBJECT on STREAM in a user-friendly way.
897 (error_object, stream))
899 /* This function can GC */
900 print_error_message(error_object, canonicalize_printcharfun(stream));
906 Lisp_Object Vfloat_output_format;
909 * This buffer should be at least as large as the max string size of the
910 * largest float, printed in the biggest notation. This is undoubtedly
911 * 20d float_output_format, with the negative of the C-constant "HUGE"
914 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
916 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
917 * case of -1e307 in 20d float_output_format. What is one to do (short of
918 * re-writing _doprnt to be more sane)?
921 void float_to_string(char *buf, fpfloat data, int maxlen)
926 if (NILP(Vfloat_output_format) || !STRINGP(Vfloat_output_format)) {
929 sz = snprintf(buf, maxlen, "%.16g", data);
930 #elif fpfloat_long_double_p
931 sz = snprintf(buf, maxlen, "%.16Lg", data);
933 assert(sz>=0 && sz<maxlen);
934 } else { /* oink oink */
936 /* Check that the spec we have is fully valid.
937 This means not only valid for printf,
938 but meant for floats, and reasonable. */
939 cp = XSTRING_DATA(Vfloat_output_format);
947 for (width = 0; (c = *cp, isdigit(c)); cp++) {
952 if (*cp != 'e' && *cp != 'f' && *cp != 'g' && *cp != 'E'
956 if (width < (int)(*cp != 'e' && *cp != 'E') || width > DBL_DIG)
962 sz = snprintf(buf, maxlen,
963 (char *)XSTRING_DATA(Vfloat_output_format), data);
964 assert(sz>=0 && sz < maxlen);
967 /* added by jwz: don't allow "1.0" to print as "1"; that destroys
968 the read-equivalence of lisp objects. (* x 1) and (* x 1.0) do
969 not do the same thing, so it's important that the printed
970 representation of that form not be corrupted by the printer.
973 Bufbyte *s = (Bufbyte *) buf; /* don't use signed chars here!
974 isdigit() can't hack them! */
981 /* if there's a non-digit, then there is a decimal point, or
982 it's in exponential notation, both of which are ok. */
985 /* otherwise, we need to hack it. */
994 /* Some machines print "0.4" as ".4". I don't like that. */
995 if (buf[0] == '.' || (buf[0] == '-' && buf[1] == '.')) {
998 for (i = strlen(buf) + 1; i >= 0; i--)
1000 buf[(buf[0] == '-' ? 1 : 0)] = '0';
1003 #endif /* HAVE_FPFLOAT */
1005 /* Print NUMBER to BUFFER.
1006 This is equivalent to sprintf (buffer, "%ld", number), only much faster.
1008 BUFFER should accept 24 bytes. This should suffice for the longest
1009 numbers on 64-bit machines, including the `-' sign and the trailing
1010 '\0'. Returns a pointer to the trailing '\0'. */
1011 char *long_to_string(char *buffer, long number, int maxlen)
1013 #if (SIZEOF_LONG != 4) && (SIZEOF_LONG != 8)
1015 int sz = snprintf(buffer, maxlen, "%ld", number);
1016 assert(sz>=0 && sz < maxlen);
1017 return buffer + strlen(buffer);
1018 #else /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
1026 #define FROB(figure) \
1028 if (force || number >= figure) { \
1029 *p++ = number / figure + '0'; \
1036 #if SIZEOF_LONG == 8
1037 FROB(1000000000000000000L);
1038 FROB(100000000000000000L);
1039 FROB(10000000000000000L);
1040 FROB(1000000000000000L);
1041 FROB(100000000000000L);
1042 FROB(10000000000000L);
1043 FROB(1000000000000L);
1044 FROB(100000000000L);
1046 #endif /* SIZEOF_LONG == 8 */
1057 *p++ = number + '0';
1060 #endif /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
1064 print_vector_internal(const char *start, const char *end,
1065 Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1067 /* This function can GC */
1069 int len = XVECTOR_LENGTH(obj);
1071 struct gcpro gcpro1, gcpro2;
1072 GCPRO2(obj, printcharfun);
1074 if (INTP(Vprint_length)) {
1075 int max = XINT(Vprint_length);
1080 write_c_string(start, printcharfun);
1081 for (i = 0; i < last; i++) {
1082 Lisp_Object elt = XVECTOR_DATA(obj)[i];
1084 write_char_internal(" ", printcharfun);
1085 print_internal(elt, printcharfun, escapeflag);
1089 write_c_string(" ...", printcharfun);
1090 write_c_string(end, printcharfun);
1093 void print_cons(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1095 /* This function can GC */
1096 struct gcpro gcpro1, gcpro2;
1098 /* If print_readably is on, print (quote -foo-) as '-foo-
1099 (Yeah, this should really be what print-pretty does, but we
1100 don't have the rest of a pretty printer, and this actually
1101 has non-negligible impact on size/speed of .elc files.)
1103 if (print_readably &&
1104 EQ(XCAR(obj), Qquote) &&
1105 CONSP(XCDR(obj)) && NILP(XCDR(XCDR(obj)))) {
1106 obj = XCAR(XCDR(obj));
1107 GCPRO2(obj, printcharfun);
1108 write_char_internal("\'", printcharfun);
1110 print_internal(obj, printcharfun, escapeflag);
1114 GCPRO2(obj, printcharfun);
1115 write_char_internal("(", printcharfun);
1119 int max = INTP(Vprint_length) ? XINT(Vprint_length) : INT_MAX;
1120 Lisp_Object tortoise;
1121 /* Use tortoise/hare to make sure circular lists don't infloop */
1123 for (tortoise = obj, len = 0;
1124 CONSP(obj); obj = XCDR(obj), len++) {
1126 write_char_internal(" ", printcharfun);
1127 if (EQ(obj, tortoise) && len > 0) {
1130 ("printing unreadable circular list");
1132 write_c_string("... <circular list>",
1137 tortoise = XCDR(tortoise);
1139 write_c_string("...", printcharfun);
1142 print_internal(XCAR(obj), printcharfun, escapeflag);
1146 write_c_string(" . ", printcharfun);
1147 print_internal(obj, printcharfun, escapeflag);
1151 write_char_internal(")", printcharfun);
1155 void print_vector(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1157 print_vector_internal("[", "]", obj, printcharfun, escapeflag);
1160 void print_string(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1162 Lisp_String *s = XSTRING(obj);
1163 /* We distinguish between Bytecounts and Charcounts, to make
1164 Vprint_string_length work correctly under Mule. */
1165 Charcount size = string_char_length(s);
1166 Charcount max = size;
1167 Bytecount bcmax = string_length(s);
1168 struct gcpro gcpro1, gcpro2;
1169 GCPRO2(obj, printcharfun);
1171 if (INTP(Vprint_string_length) && XINT(Vprint_string_length) < max) {
1172 max = XINT(Vprint_string_length);
1173 bcmax = charcount_to_bytecount(string_data(s), max);
1181 /* This deals with GC-relocation and Mule. */
1182 output_string(printcharfun, 0, obj, 0, bcmax);
1184 write_c_string(" ...", printcharfun);
1186 Bytecount i, last = 0;
1188 write_char_internal("\"", printcharfun);
1189 for (i = 0; i < bcmax; i++) {
1190 Bufbyte ch = string_byte(s, i);
1191 if (ch == '\"' || ch == '\\'
1192 || (ch == '\n' && print_escape_newlines)) {
1194 output_string(printcharfun, 0, obj,
1198 write_c_string("\\n", printcharfun);
1200 write_char_internal("\\", printcharfun);
1201 /* This is correct for Mule because the
1202 character is either \ or " */
1203 write_char_internal(string_data(s) + i,
1210 output_string(printcharfun, 0, obj, last, bcmax - last);
1213 write_c_string(" ...", printcharfun);
1214 write_char_internal("\"", printcharfun);
1220 default_object_printer(Lisp_Object obj, Lisp_Object printcharfun,
1223 struct lcrecord_header *header = (struct lcrecord_header *)XPNTR(obj);
1226 error("printing unreadable object #<%s 0x%x>",
1227 LHEADER_IMPLEMENTATION(&header->lheader)->name,
1230 write_fmt_string(printcharfun, "#<%s 0x%x>",
1231 LHEADER_IMPLEMENTATION(&header->lheader)->name, header->uid);
1235 internal_object_printer(Lisp_Object obj, Lisp_Object printcharfun,
1238 write_fmt_string(printcharfun, "#<INTERNAL OBJECT (SXEmacs bug?) (%s) 0x%lx>",
1239 XRECORD_LHEADER_IMPLEMENTATION(obj)->name,
1240 (unsigned long)XPNTR(obj));
1243 enum printing_badness {
1244 BADNESS_INTEGER_OBJECT,
1245 BADNESS_POINTER_OBJECT,
1250 printing_major_badness(Lisp_Object printcharfun,
1251 Char_ASCII * badness_string, int type, void *val,
1252 enum printing_badness badness)
1258 case BADNESS_INTEGER_OBJECT:
1259 len = snprintf(buf, sizeof(buf), "%s %d object %ld", badness_string, type,
1263 case BADNESS_POINTER_OBJECT:
1264 len = snprintf(buf, sizeof(buf), "%s %d object %p", badness_string, type, val);
1267 case BADNESS_NO_TYPE:
1268 len = snprintf(buf, sizeof(buf), "%s object %p", badness_string, val);
1271 len = snprintf(buf, sizeof(buf), "%s unknown badness %d",
1272 badness_string, badness);
1275 assert(len >= 0 && len < sizeof(buf));
1277 /* Don't abort or signal if called from debug_print() or already
1279 if (!inhibit_non_essential_printing_operations) {
1280 #ifdef ERROR_CHECK_TYPES
1282 #else /* not ERROR_CHECK_TYPES */
1284 type_error(Qinternal_error, "printing %s", buf);
1285 #endif /* not ERROR_CHECK_TYPES */
1287 write_fmt_string(printcharfun,
1288 "#<EMACS BUG: %s Save your buffers immediately and "
1289 "please report this bug>", buf);
1293 print_internal(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1295 /* This function can GC */
1296 /* defined in emacs.c */
1297 extern int inhibit_autoloads, nodumpfile;
1301 /* Emacs won't print while GCing, but an external debugger might */
1306 /* #### Both input and output streams should have a flag associated
1307 with them indicating whether output to that stream, or strings
1308 read from the stream, get translated using Fgettext(). Such a
1309 stream is called a "translating stream". For the minibuffer and
1310 external-debugging-output this is always true on output, and
1311 with-output-to-temp-buffer sets the flag to true for the buffer
1312 it creates. This flag should also be user-settable. Perhaps it
1313 should be split up into two flags, one for input and one for
1317 /* Try out custom printing */
1318 if (UNLIKELY(!(bool)inhibit_autoloads && !(bool)nodumpfile) &&
1319 !EQ(Qnil, Vcustom_object_printer) &&
1320 !EQ(Qnil, apply1(Vcustom_object_printer,
1321 Fcons(obj, Fcons(printcharfun, Qnil))))) {
1325 /* Detect circularities and truncate them.
1326 No need to offer any alternative--this is better than an error. */
1327 if (CONSP(obj) || VECTORP(obj) || COMPILED_FUNCTIONP(obj)) {
1329 for (i = 0; i < print_depth; i++)
1330 if (EQ(obj, being_printed[i])) {
1333 long_to_string(buf + 1, i, sizeof(buf)-1);
1334 write_c_string(buf, printcharfun);
1339 being_printed[print_depth] = obj;
1342 if (print_depth > PRINT_CIRCLE) {
1343 error("Apparently circular structure being printed");
1346 switch (XTYPE(obj)) {
1347 case Lisp_Type_Int_Even:
1348 case Lisp_Type_Int_Odd: {
1349 /* ASCII Decimal representation uses 2.4 times as many bits as
1351 char buf[3 * sizeof(EMACS_INT) + 5];
1352 long_to_string(buf, XINT(obj),sizeof(buf));
1353 write_c_string(buf, printcharfun);
1357 case Lisp_Type_Char: {
1358 /* God intended that this be #\..., you know. */
1360 memset(buf, 0, sizeof(buf));
1361 Emchar ch = XCHAR(obj);
1379 if ((ch + 64) == '\\')
1383 } else if (ch < 127) {
1384 /* syntactically special characters should be
1406 } else if (ch == 127) {
1407 *p++ = '\\', *p++ = '^', *p++ = '?';
1408 } else if (ch < 160) {
1409 *p++ = '\\', *p++ = '^';
1410 p += set_charptr_emchar((Bufbyte *) p, ch + 64);
1412 p += set_charptr_emchar((Bufbyte *) p, ch);
1415 output_string(printcharfun, (Bufbyte *) buf, Qnil, 0,
1421 case Lisp_Type_Record: {
1422 struct lrecord_header *lheader = XRECORD_LHEADER(obj);
1424 /* Try to check for various sorts of bogus pointers if we're in
1425 a situation where it may be likely -- i.e. called from
1426 debug_print() or we're already crashing. In such cases,
1427 (further) crashing is counterproductive. */
1429 if (inhibit_non_essential_printing_operations &&
1430 !debug_can_access_memory(lheader, sizeof(*lheader))) {
1431 write_fmt_string(printcharfun,
1432 "#<EMACS BUG: BAD MEMORY ACCESS %p>",
1437 if (CONSP(obj) || VECTORP(obj)) {
1438 /* If deeper than spec'd depth, print placeholder. */
1439 if (INTP(Vprint_level)
1440 && print_depth > XINT(Vprint_level)) {
1441 write_c_string("...", printcharfun);
1446 if (lheader->type == lrecord_type_free) {
1447 printing_major_badness(printcharfun,
1452 } else if (lheader->type == lrecord_type_undefined) {
1453 printing_major_badness(printcharfun,
1454 "lrecord_type_undefined",
1458 } else if (lheader->type >= lrecord_type_count) {
1459 printing_major_badness(printcharfun,
1460 "illegal lrecord type",
1461 (int)(lheader->type),
1463 BADNESS_POINTER_OBJECT);
1467 /* Further checks for bad memory in critical situations. We
1468 don't normally do these because they may be expensive or
1469 weird (e.g. under Unix we typically have to set a SIGSEGV
1470 handler and try to trigger a seg fault). */
1472 if (inhibit_non_essential_printing_operations) {
1473 const struct lrecord_implementation *imp =
1474 LHEADER_IMPLEMENTATION(lheader);
1476 if (!debug_can_access_memory
1477 (lheader, imp->size_in_bytes_method ?
1478 imp->size_in_bytes_method(lheader) :
1479 imp->static_size)) {
1482 "#<EMACS BUG: type %s "
1483 "BAD MEMORY ACCESS %p>",
1484 LHEADER_IMPLEMENTATION
1485 (lheader)->name, lheader);
1490 Lisp_String *l = (Lisp_String *)lheader;
1491 if (!debug_can_access_memory(
1492 l->data, l->size)) {
1496 "(CAN'T ACCESS STRING "
1497 "DATA %p)>", lheader, l->data);
1503 if (LHEADER_IMPLEMENTATION(lheader)->printer) {
1504 ((LHEADER_IMPLEMENTATION(lheader)->printer)
1505 (obj, printcharfun, escapeflag));
1507 default_object_printer(obj, printcharfun, escapeflag);
1513 /* We're in trouble if this happens! */
1514 printing_major_badness(printcharfun,
1515 "illegal data type", XTYPE(obj),
1517 BADNESS_INTEGER_OBJECT);
1526 void print_symbol(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1528 /* This function can GC */
1529 /* #### Bug!! (intern "") isn't printed in some distinguished way */
1530 /* #### (the reader also loses on it) */
1531 Lisp_String *name = symbol_name(XSYMBOL(obj));
1532 Bytecount size = string_length(name);
1533 struct gcpro gcpro1, gcpro2;
1536 /* This deals with GC-relocation */
1537 Lisp_Object nameobj;
1538 XSETSTRING(nameobj, name);
1539 output_string(printcharfun, 0, nameobj, 0, size);
1542 GCPRO2(obj, printcharfun);
1544 /* If we print an uninterned symbol as part of a complex object and
1545 the flag print-gensym is non-nil, prefix it with #n= to read the
1546 object back with the #n# reader syntax later if needed. */
1547 if (!NILP(Vprint_gensym)
1548 /* #### Test whether this produces a noticeable slow-down for
1549 printing when print-gensym is non-nil. */
1550 && !EQ(obj, oblookup(Vobarray,
1551 string_data(symbol_name(XSYMBOL(obj))),
1552 string_length(symbol_name(XSYMBOL(obj)))))) {
1553 if (print_depth > 1) {
1554 Lisp_Object tem = Fassq(obj, Vprint_gensym_alist);
1556 write_char_internal("#", printcharfun);
1557 print_internal(XCDR(tem), printcharfun,
1559 write_char_internal("#", printcharfun);
1563 if (CONSP(Vprint_gensym_alist)) {
1564 /* Vprint_gensym_alist is exposed to Lisp, so we
1565 have to be careful. */
1566 CHECK_CONS(XCAR(Vprint_gensym_alist));
1568 (XCAR(Vprint_gensym_alist)));
1572 (Vprint_gensym_alist))) +
1576 Vprint_gensym_alist =
1577 Fcons(Fcons(obj, tem), Vprint_gensym_alist);
1579 write_char_internal("#", printcharfun);
1580 print_internal(tem, printcharfun, escapeflag);
1581 write_char_internal("=", printcharfun);
1584 write_c_string("#:", printcharfun);
1587 /* Does it look like an integer or a float? */
1589 Bufbyte *data = string_data(name);
1590 Bytecount confusing = 0;
1593 goto not_yet_confused; /* Really confusing */
1594 else if (isdigit(data[0]))
1597 goto not_yet_confused;
1598 else if (data[0] == '-' || data[0] == '+')
1601 goto not_yet_confused;
1603 for (; confusing < size; confusing++) {
1604 if (!isdigit(data[confusing])) {
1613 /* #### Ugh, this is needlessly complex and slow for what we
1614 need here. It might be a good idea to copy equivalent code
1615 from FSF. --hniksic */
1616 confusing = isfloat_string((char *)data);
1619 write_char_internal("\\", printcharfun);
1623 Lisp_Object nameobj;
1627 XSETSTRING(nameobj, name);
1628 for (i = 0; i < size; i++) {
1629 switch (string_byte(name, i)) {
1677 output_string(printcharfun, 0, nameobj,
1679 write_char_internal("\\", printcharfun);
1685 output_string(printcharfun, 0, nameobj, last, size - last);
1690 /* Useful on systems or in places where writing to stdout is unavailable or
1693 static int alternate_do_pointer;
1694 static char alternate_do_string[5000];
1696 DEFUN("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0, /*
1697 Append CHARACTER to the array `alternate_do_string'.
1698 This can be used in place of `external-debugging-output' as a function
1699 to be passed to `print'. Before calling `print', set `alternate_do_pointer'
1704 Bufbyte str[MAX_EMCHAR_LEN];
1707 const Extbyte *extptr;
1709 CHECK_CHAR_COERCE_INT(character);
1710 len = set_charptr_emchar(str, XCHAR(character));
1711 TO_EXTERNAL_FORMAT(DATA, (str, len),
1712 ALLOCA, (extptr, extlen), Qterminal);
1713 memcpy(alternate_do_string + alternate_do_pointer, extptr, extlen);
1714 alternate_do_pointer += extlen;
1715 alternate_do_string[alternate_do_pointer] = 0;
1719 DEFUN("external-debugging-output", Fexternal_debugging_output, 1, 3, 0, /*
1720 Write CHAR-OR-STRING to stderr or stdout.
1721 If optional arg STDOUT-P is non-nil, write to stdout; otherwise, write
1722 to stderr. You can use this function to write directly to the terminal.
1723 This function can be used as the STREAM argument of Fprint() or the like.
1725 Under MS Windows, this writes output to the console window (which is
1726 created, if necessary), unless SXEmacs is being run noninteractively
1727 \(i.e. using the `-batch' argument).
1729 If you have opened a termscript file (using `open-termscript'), then
1730 the output also will be logged to this file.
1732 (char_or_string, stdout_p, device))
1735 struct console *con = 0;
1738 if (!NILP(stdout_p))
1743 CHECK_LIVE_DEVICE(device);
1744 if (!DEVICE_TTY_P(XDEVICE(device)) &&
1745 !DEVICE_STREAM_P(XDEVICE(device)))
1746 signal_simple_error("Must be tty or stream device",
1748 con = XCONSOLE(DEVICE_CONSOLE(XDEVICE(device)));
1749 if (DEVICE_TTY_P(XDEVICE(device))) {
1751 } else if (!NILP(stdout_p)) {
1752 file = CONSOLE_STREAM_DATA(con)->out;
1754 file = CONSOLE_STREAM_DATA(con)->err;
1758 if (STRINGP(char_or_string))
1759 write_string_to_stdio_stream(file, con,
1760 XSTRING_DATA(char_or_string),
1761 0, XSTRING_LENGTH(char_or_string),
1764 Bufbyte str[MAX_EMCHAR_LEN];
1767 CHECK_CHAR_COERCE_INT(char_or_string);
1768 len = set_charptr_emchar(str, XCHAR(char_or_string));
1769 write_string_to_stdio_stream(file, con, str, 0, len, Qterminal,
1773 return char_or_string;
1776 DEFUN("open-termscript", Fopen_termscript, 1, 1, "FOpen termscript file: ", /*
1777 Start writing all terminal output to FILENAME as well as the terminal.
1778 FILENAME = nil means just close any termscript file currently open.
1782 /* This function can GC */
1783 if (termscript != 0) {
1788 if (!NILP(filename)) {
1789 filename = Fexpand_file_name(filename, Qnil);
1790 termscript = fopen((char *)XSTRING_DATA(filename), "w");
1791 if (termscript == NULL)
1792 report_file_error("Opening termscript",
1799 /* Debugging kludge -- unbuffered */
1800 static int debug_print_length = 50;
1801 static int debug_print_level = 15;
1802 static int debug_print_readably = -1;
1804 static void debug_print_no_newline(Lisp_Object debug_print_obj)
1806 /* This function can GC */
1807 int save_print_readably = print_readably;
1808 int save_print_depth = print_depth;
1809 Lisp_Object save_Vprint_length = Vprint_length;
1810 Lisp_Object save_Vprint_level = Vprint_level;
1811 Lisp_Object save_Vinhibit_quit = Vinhibit_quit;
1812 struct gcpro gcpro1, gcpro2, gcpro3;
1813 GCPRO3(save_Vprint_level, save_Vprint_length, save_Vinhibit_quit);
1817 ("** gc-in-progress! Bad idea to print anything! **\n");
1820 print_readably = debug_print_readably != -1 ? debug_print_readably : 0;
1822 inhibit_non_essential_printing_operations = 1;
1823 /* Could use unwind-protect, but why bother? */
1824 if (debug_print_length > 0)
1825 Vprint_length = make_int(debug_print_length);
1826 if (debug_print_level > 0)
1827 Vprint_level = make_int(debug_print_level);
1829 print_internal(debug_print_obj, Qexternal_debugging_output, 1);
1830 alternate_do_pointer = 0;
1831 print_internal(debug_print_obj, Qalternate_debugging_output, 1);
1833 Vinhibit_quit = save_Vinhibit_quit;
1834 Vprint_level = save_Vprint_level;
1835 Vprint_length = save_Vprint_length;
1836 print_depth = save_print_depth;
1837 print_readably = save_print_readably;
1838 inhibit_non_essential_printing_operations = 0;
1843 void debug_print(Lisp_Object debug_print_obj)
1845 debug_print_no_newline(debug_print_obj);
1849 /* Debugging kludge -- unbuffered */
1850 /* This function provided for the benefit of the debugger. */
1851 void debug_backtrace(void);
1852 void debug_backtrace(void)
1854 /* This function can GC */
1855 int old_print_readably = print_readably;
1856 int old_print_depth = print_depth;
1857 Lisp_Object old_print_length = Vprint_length;
1858 Lisp_Object old_print_level = Vprint_level;
1859 Lisp_Object old_inhibit_quit = Vinhibit_quit;
1861 struct gcpro gcpro1, gcpro2, gcpro3;
1862 GCPRO3(old_print_level, old_print_length, old_inhibit_quit);
1866 ("** gc-in-progress! Bad idea to print anything! **\n");
1871 inhibit_non_essential_printing_operations = 1;
1872 /* Could use unwind-protect, but why bother? */
1873 if (debug_print_length > 0)
1874 Vprint_length = make_int(debug_print_length);
1875 if (debug_print_level > 0)
1876 Vprint_level = make_int(debug_print_level);
1878 Fbacktrace(Qexternal_debugging_output, Qt);
1881 Vinhibit_quit = old_inhibit_quit;
1882 Vprint_level = old_print_level;
1883 Vprint_length = old_print_length;
1884 print_depth = old_print_depth;
1885 print_readably = old_print_readably;
1886 inhibit_non_essential_printing_operations = 0;
1892 void debug_short_backtrace(int length)
1895 struct backtrace *bt = backtrace_list;
1897 while (length > 0 && bt) {
1901 if (COMPILED_FUNCTIONP(*bt->function)) {
1902 #if defined(COMPILED_FUNCTION_ANNOTATION_HACK)
1904 compiled_function_annotation(XCOMPILED_FUNCTION
1907 Lisp_Object ann = Qnil;
1910 stderr_out("<compiled-function from ");
1911 debug_print_no_newline(ann);
1915 ("<compiled-function of unknown origin>");
1918 debug_print_no_newline(*bt->function);
1926 #endif /* debugging kludge */
1928 void syms_of_print(void)
1930 defsymbol(&Qstandard_output, "standard-output");
1932 defsymbol(&Qprint_length, "print-length");
1934 defsymbol(&Qprint_string_length, "print-string-length");
1936 defsymbol(&Qdisplay_error, "display-error");
1937 defsymbol(&Qprint_message_label, "print-message-label");
1940 DEFSUBR(Fprin1_to_string);
1943 DEFSUBR(Ferror_message_string);
1944 DEFSUBR(Fdisplay_error);
1946 DEFSUBR(Fwrite_char);
1947 DEFSUBR(Falternate_debugging_output);
1948 DEFSUBR(Fexternal_debugging_output);
1949 DEFSUBR(Fopen_termscript);
1950 defsymbol(&Qexternal_debugging_output, "external-debugging-output");
1951 defsymbol(&Qalternate_debugging_output, "alternate-debugging-output");
1952 DEFSUBR(Fwith_output_to_temp_buffer);
1955 void reinit_vars_of_print(void)
1957 alternate_do_pointer = 0;
1960 void vars_of_print(void)
1962 reinit_vars_of_print();
1964 DEFVAR_LISP("standard-output", &Vstandard_output /*
1965 Output stream `print' uses by default for outputting a character.
1966 This may be any function of one argument.
1967 It may also be a buffer (output is inserted before point)
1968 or a marker (output is inserted and the marker is advanced)
1969 or the symbol t (output appears in the minibuffer line).
1971 Vstandard_output = Qt;
1974 DEFVAR_LISP("float-output-format", &Vfloat_output_format /*
1975 The format descriptor string that lisp uses to print floats.
1976 This is a %-spec like those accepted by `printf' in C,
1977 but with some restrictions. It must start with the two characters `%.'.
1978 After that comes an integer precision specification,
1979 and then a letter which controls the format.
1980 The letters allowed are `e', `f' and `g'.
1981 Use `e' for exponential notation "DIG.DIGITSeEXPT"
1982 Use `f' for decimal point notation "DIGITS.DIGITS".
1983 Use `g' to choose the shorter of those two formats for the number at hand.
1984 The precision in any of these cases is the number of digits following
1985 the decimal point. With `f', a precision of 0 means to omit the
1986 decimal point. 0 is not allowed with `f' or `g'.
1988 A value of nil means to use `%.16g'.
1990 Regardless of the value of `float-output-format', a floating point number
1991 will never be printed in such a way that it is ambiguous with an integer;
1992 that is, a floating-point number will always be printed with a decimal
1993 point and/or an exponent, even if the digits following the decimal point
1994 are all zero. This is to preserve read-equivalence.
1996 Vfloat_output_format = Qnil;
1997 #endif /* HAVE_FPFLOAT */
1999 DEFVAR_LISP("print-length", &Vprint_length /*
2000 Maximum length of list or vector to print before abbreviating.
2001 A value of nil means no limit.
2003 Vprint_length = Qnil;
2005 DEFVAR_LISP("print-string-length", &Vprint_string_length /*
2006 Maximum length of string to print before abbreviating.
2007 A value of nil means no limit.
2009 Vprint_string_length = Qnil;
2011 DEFVAR_LISP("print-level", &Vprint_level /*
2012 Maximum depth of list nesting to print before abbreviating.
2013 A value of nil means no limit.
2015 Vprint_level = Qnil;
2017 DEFVAR_BOOL("print-escape-newlines", &print_escape_newlines /*
2018 Non-nil means print newlines in strings as backslash-n.
2020 print_escape_newlines = 0;
2022 DEFVAR_BOOL("print-readably", &print_readably /*
2023 If non-nil, then all objects will be printed in a readable form.
2024 If an object has no readable representation, then an error is signalled.
2025 When print-readably is true, compiled-function objects will be written in
2026 #[...] form instead of in #<compiled-function [...]> form, and two-element
2027 lists of the form (quote object) will be written as the equivalent 'object.
2028 Do not SET this variable; bind it instead.
2032 /* #### I think this should default to t. But we'd better wait
2033 until we see that it works out. */
2034 DEFVAR_LISP("print-gensym", &Vprint_gensym /*
2035 If non-nil, then uninterned symbols will be printed specially.
2036 Uninterned symbols are those which are not present in `obarray', that is,
2037 those which were made with `make-symbol' or by calling `intern' with a
2040 When print-gensym is true, such symbols will be preceded by "#:",
2041 which causes the reader to create a new symbol instead of interning
2042 and returning an existing one. Beware: the #: syntax creates a new
2043 symbol each time it is seen, so if you print an object which contains
2044 two pointers to the same uninterned symbol, `read' will not duplicate
2047 If the value of `print-gensym' is a cons cell, then in addition
2048 refrain from clearing `print-gensym-alist' on entry to and exit from
2049 printing functions, so that the use of #...# and #...= can carry over
2050 for several separately printed objects.
2052 Vprint_gensym = Qnil;
2054 DEFVAR_LISP("print-gensym-alist", &Vprint_gensym_alist /*
2055 Association list of elements (GENSYM . N) to guide use of #N# and #N=.
2056 In each element, GENSYM is an uninterned symbol that has been associated
2057 with #N= for the specified value of N.
2059 Vprint_gensym_alist = Qnil;
2061 DEFVAR_LISP("print-message-label", &Vprint_message_label /*
2062 Label for minibuffer messages created with `print'. This should
2063 generally be bound with `let' rather than set. (See `display-message'.)
2065 Vprint_message_label = Qprint;
2067 DEFVAR_LISP("custom-object-printer", &Vcustom_object_printer /*
2068 Function to call in order to print custom object.
2070 Vcustom_object_printer = Qnil;