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)
926 if (NILP(Vfloat_output_format) || !STRINGP(Vfloat_output_format)) {
929 sprintf(buf, "%.16g", data);
930 #elif fpfloat_long_double_p
931 sprintf(buf, "%.16Lg", data);
933 } else { /* oink oink */
935 /* Check that the spec we have is fully valid.
936 This means not only valid for printf,
937 but meant for floats, and reasonable. */
938 cp = XSTRING_DATA(Vfloat_output_format);
946 for (width = 0; (c = *cp, isdigit(c)); cp++) {
951 if (*cp != 'e' && *cp != 'f' && *cp != 'g' && *cp != 'E'
955 if (width < (int)(*cp != 'e' && *cp != 'E') || width > DBL_DIG)
961 sprintf(buf, (char *)XSTRING_DATA(Vfloat_output_format), data);
964 /* added by jwz: don't allow "1.0" to print as "1"; that destroys
965 the read-equivalence of lisp objects. (* x 1) and (* x 1.0) do
966 not do the same thing, so it's important that the printed
967 representation of that form not be corrupted by the printer.
970 Bufbyte *s = (Bufbyte *) buf; /* don't use signed chars here!
971 isdigit() can't hack them! */
975 /* if there's a non-digit, then there is a decimal point, or
976 it's in exponential notation, both of which are ok. */
979 /* otherwise, we need to hack it. */
986 /* Some machines print "0.4" as ".4". I don't like that. */
987 if (buf[0] == '.' || (buf[0] == '-' && buf[1] == '.')) {
989 for (i = strlen(buf) + 1; i >= 0; i--)
991 buf[(buf[0] == '-' ? 1 : 0)] = '0';
994 #endif /* HAVE_FPFLOAT */
996 /* Print NUMBER to BUFFER.
997 This is equivalent to sprintf (buffer, "%ld", number), only much faster.
999 BUFFER should accept 24 bytes. This should suffice for the longest
1000 numbers on 64-bit machines, including the `-' sign and the trailing
1001 '\0'. Returns a pointer to the trailing '\0'. */
1002 char *long_to_string(char *buffer, long number)
1004 #if (SIZEOF_LONG != 4) && (SIZEOF_LONG != 8)
1006 sprintf(buffer, "%ld", number);
1007 return buffer + strlen(buffer);
1008 #else /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
1016 #define FROB(figure) do { \
1017 if (force || number >= figure) \
1018 *p++ = number / figure + '0', number %= figure, force = 1; \
1020 #if SIZEOF_LONG == 8
1021 FROB(1000000000000000000L);
1022 FROB(100000000000000000L);
1023 FROB(10000000000000000L);
1024 FROB(1000000000000000L);
1025 FROB(100000000000000L);
1026 FROB(10000000000000L);
1027 FROB(1000000000000L);
1028 FROB(100000000000L);
1030 #endif /* SIZEOF_LONG == 8 */
1041 *p++ = number + '0';
1044 #endif /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
1048 print_vector_internal(const char *start, const char *end,
1049 Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1051 /* This function can GC */
1053 int len = XVECTOR_LENGTH(obj);
1055 struct gcpro gcpro1, gcpro2;
1056 GCPRO2(obj, printcharfun);
1058 if (INTP(Vprint_length)) {
1059 int max = XINT(Vprint_length);
1064 write_c_string(start, printcharfun);
1065 for (i = 0; i < last; i++) {
1066 Lisp_Object elt = XVECTOR_DATA(obj)[i];
1068 write_char_internal(" ", printcharfun);
1069 print_internal(elt, printcharfun, escapeflag);
1073 write_c_string(" ...", printcharfun);
1074 write_c_string(end, printcharfun);
1077 void print_cons(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1079 /* This function can GC */
1080 struct gcpro gcpro1, gcpro2;
1082 /* If print_readably is on, print (quote -foo-) as '-foo-
1083 (Yeah, this should really be what print-pretty does, but we
1084 don't have the rest of a pretty printer, and this actually
1085 has non-negligible impact on size/speed of .elc files.)
1087 if (print_readably &&
1088 EQ(XCAR(obj), Qquote) &&
1089 CONSP(XCDR(obj)) && NILP(XCDR(XCDR(obj)))) {
1090 obj = XCAR(XCDR(obj));
1091 GCPRO2(obj, printcharfun);
1092 write_char_internal("\'", printcharfun);
1094 print_internal(obj, printcharfun, escapeflag);
1098 GCPRO2(obj, printcharfun);
1099 write_char_internal("(", printcharfun);
1103 int max = INTP(Vprint_length) ? XINT(Vprint_length) : INT_MAX;
1104 Lisp_Object tortoise;
1105 /* Use tortoise/hare to make sure circular lists don't infloop */
1107 for (tortoise = obj, len = 0;
1108 CONSP(obj); obj = XCDR(obj), len++) {
1110 write_char_internal(" ", printcharfun);
1111 if (EQ(obj, tortoise) && len > 0) {
1114 ("printing unreadable circular list");
1116 write_c_string("... <circular list>",
1121 tortoise = XCDR(tortoise);
1123 write_c_string("...", printcharfun);
1126 print_internal(XCAR(obj), printcharfun, escapeflag);
1130 write_c_string(" . ", printcharfun);
1131 print_internal(obj, printcharfun, escapeflag);
1135 write_char_internal(")", printcharfun);
1139 void print_vector(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1141 print_vector_internal("[", "]", obj, printcharfun, escapeflag);
1144 void print_string(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1146 Lisp_String *s = XSTRING(obj);
1147 /* We distinguish between Bytecounts and Charcounts, to make
1148 Vprint_string_length work correctly under Mule. */
1149 Charcount size = string_char_length(s);
1150 Charcount max = size;
1151 Bytecount bcmax = string_length(s);
1152 struct gcpro gcpro1, gcpro2;
1153 GCPRO2(obj, printcharfun);
1155 if (INTP(Vprint_string_length) && XINT(Vprint_string_length) < max) {
1156 max = XINT(Vprint_string_length);
1157 bcmax = charcount_to_bytecount(string_data(s), max);
1165 /* This deals with GC-relocation and Mule. */
1166 output_string(printcharfun, 0, obj, 0, bcmax);
1168 write_c_string(" ...", printcharfun);
1170 Bytecount i, last = 0;
1172 write_char_internal("\"", printcharfun);
1173 for (i = 0; i < bcmax; i++) {
1174 Bufbyte ch = string_byte(s, i);
1175 if (ch == '\"' || ch == '\\'
1176 || (ch == '\n' && print_escape_newlines)) {
1178 output_string(printcharfun, 0, obj,
1182 write_c_string("\\n", printcharfun);
1184 write_char_internal("\\", printcharfun);
1185 /* This is correct for Mule because the
1186 character is either \ or " */
1187 write_char_internal(string_data(s) + i,
1194 output_string(printcharfun, 0, obj, last, bcmax - last);
1197 write_c_string(" ...", printcharfun);
1198 write_char_internal("\"", printcharfun);
1204 default_object_printer(Lisp_Object obj, Lisp_Object printcharfun,
1207 struct lcrecord_header *header = (struct lcrecord_header *)XPNTR(obj);
1210 error("printing unreadable object #<%s 0x%x>",
1211 LHEADER_IMPLEMENTATION(&header->lheader)->name,
1214 write_fmt_string(printcharfun, "#<%s 0x%x>",
1215 LHEADER_IMPLEMENTATION(&header->lheader)->name, header->uid);
1219 internal_object_printer(Lisp_Object obj, Lisp_Object printcharfun,
1222 write_fmt_string(printcharfun, "#<INTERNAL OBJECT (SXEmacs bug?) (%s) 0x%lx>",
1223 XRECORD_LHEADER_IMPLEMENTATION(obj)->name,
1224 (unsigned long)XPNTR(obj));
1227 enum printing_badness {
1228 BADNESS_INTEGER_OBJECT,
1229 BADNESS_POINTER_OBJECT,
1234 printing_major_badness(Lisp_Object printcharfun,
1235 Char_ASCII * badness_string, int type, void *val,
1236 enum printing_badness badness)
1242 case BADNESS_INTEGER_OBJECT:
1243 len = snprintf(buf, sizeof(buf), "%s %d object %ld", badness_string, type,
1247 case BADNESS_POINTER_OBJECT:
1248 len = snprintf(buf, sizeof(buf), "%s %d object %p", badness_string, type, val);
1251 case BADNESS_NO_TYPE:
1252 len = snprintf(buf, sizeof(buf), "%s object %p", badness_string, val);
1255 len = snprintf(buf, sizeof(buf), "%s unknown badness %d",
1256 badness_string, badness);
1259 assert(len >= 0 && len < sizeof(buf));
1261 /* Don't abort or signal if called from debug_print() or already
1263 if (!inhibit_non_essential_printing_operations) {
1264 #ifdef ERROR_CHECK_TYPES
1266 #else /* not ERROR_CHECK_TYPES */
1268 type_error(Qinternal_error, "printing %s", buf);
1269 #endif /* not ERROR_CHECK_TYPES */
1271 write_fmt_string(printcharfun,
1272 "#<EMACS BUG: %s Save your buffers immediately and "
1273 "please report this bug>", buf);
1277 print_internal(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1279 /* This function can GC */
1280 /* defined in emacs.c */
1281 extern int inhibit_autoloads, nodumpfile;
1285 /* Emacs won't print while GCing, but an external debugger might */
1290 /* #### Both input and output streams should have a flag associated
1291 with them indicating whether output to that stream, or strings
1292 read from the stream, get translated using Fgettext(). Such a
1293 stream is called a "translating stream". For the minibuffer and
1294 external-debugging-output this is always true on output, and
1295 with-output-to-temp-buffer sets the flag to true for the buffer
1296 it creates. This flag should also be user-settable. Perhaps it
1297 should be split up into two flags, one for input and one for
1301 /* Try out custom printing */
1302 if (UNLIKELY(!(bool)inhibit_autoloads && !(bool)nodumpfile) &&
1303 !EQ(Qnil, Vcustom_object_printer) &&
1304 !EQ(Qnil, apply1(Vcustom_object_printer,
1305 Fcons(obj, Fcons(printcharfun, Qnil))))) {
1309 /* Detect circularities and truncate them.
1310 No need to offer any alternative--this is better than an error. */
1311 if (CONSP(obj) || VECTORP(obj) || COMPILED_FUNCTIONP(obj)) {
1313 for (i = 0; i < print_depth; i++)
1314 if (EQ(obj, being_printed[i])) {
1317 long_to_string(buf + 1, i);
1318 write_c_string(buf, printcharfun);
1323 being_printed[print_depth] = obj;
1326 if (print_depth > PRINT_CIRCLE) {
1327 error("Apparently circular structure being printed");
1330 switch (XTYPE(obj)) {
1331 case Lisp_Type_Int_Even:
1332 case Lisp_Type_Int_Odd: {
1333 /* ASCII Decimal representation uses 2.4 times as many bits as
1335 char buf[3 * sizeof(EMACS_INT) + 5];
1336 long_to_string(buf, XINT(obj));
1337 write_c_string(buf, printcharfun);
1341 case Lisp_Type_Char: {
1342 /* God intended that this be #\..., you know. */
1344 memset(buf, 0, sizeof(buf));
1345 Emchar ch = XCHAR(obj);
1363 if ((ch + 64) == '\\')
1367 } else if (ch < 127) {
1368 /* syntactically special characters should be
1390 } else if (ch == 127) {
1391 *p++ = '\\', *p++ = '^', *p++ = '?';
1392 } else if (ch < 160) {
1393 *p++ = '\\', *p++ = '^';
1394 p += set_charptr_emchar((Bufbyte *) p, ch + 64);
1396 p += set_charptr_emchar((Bufbyte *) p, ch);
1399 output_string(printcharfun, (Bufbyte *) buf, Qnil, 0,
1405 case Lisp_Type_Record: {
1406 struct lrecord_header *lheader = XRECORD_LHEADER(obj);
1408 /* Try to check for various sorts of bogus pointers if we're in
1409 a situation where it may be likely -- i.e. called from
1410 debug_print() or we're already crashing. In such cases,
1411 (further) crashing is counterproductive. */
1413 if (inhibit_non_essential_printing_operations &&
1414 !debug_can_access_memory(lheader, sizeof(*lheader))) {
1415 write_fmt_string(printcharfun,
1416 "#<EMACS BUG: BAD MEMORY ACCESS %p>",
1421 if (CONSP(obj) || VECTORP(obj)) {
1422 /* If deeper than spec'd depth, print placeholder. */
1423 if (INTP(Vprint_level)
1424 && print_depth > XINT(Vprint_level)) {
1425 write_c_string("...", printcharfun);
1430 if (lheader->type == lrecord_type_free) {
1431 printing_major_badness(printcharfun,
1436 } else if (lheader->type == lrecord_type_undefined) {
1437 printing_major_badness(printcharfun,
1438 "lrecord_type_undefined",
1442 } else if (lheader->type >= lrecord_type_count) {
1443 printing_major_badness(printcharfun,
1444 "illegal lrecord type",
1445 (int)(lheader->type),
1447 BADNESS_POINTER_OBJECT);
1451 /* Further checks for bad memory in critical situations. We
1452 don't normally do these because they may be expensive or
1453 weird (e.g. under Unix we typically have to set a SIGSEGV
1454 handler and try to trigger a seg fault). */
1456 if (inhibit_non_essential_printing_operations) {
1457 const struct lrecord_implementation *imp =
1458 LHEADER_IMPLEMENTATION(lheader);
1460 if (!debug_can_access_memory
1461 (lheader, imp->size_in_bytes_method ?
1462 imp->size_in_bytes_method(lheader) :
1463 imp->static_size)) {
1466 "#<EMACS BUG: type %s "
1467 "BAD MEMORY ACCESS %p>",
1468 LHEADER_IMPLEMENTATION
1469 (lheader)->name, lheader);
1474 Lisp_String *l = (Lisp_String *)lheader;
1475 if (!debug_can_access_memory(
1476 l->data, l->size)) {
1480 "(CAN'T ACCESS STRING "
1481 "DATA %p)>", lheader, l->data);
1487 if (LHEADER_IMPLEMENTATION(lheader)->printer) {
1488 ((LHEADER_IMPLEMENTATION(lheader)->printer)
1489 (obj, printcharfun, escapeflag));
1491 default_object_printer(obj, printcharfun, escapeflag);
1497 /* We're in trouble if this happens! */
1498 printing_major_badness(printcharfun,
1499 "illegal data type", XTYPE(obj),
1501 BADNESS_INTEGER_OBJECT);
1510 void print_symbol(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1512 /* This function can GC */
1513 /* #### Bug!! (intern "") isn't printed in some distinguished way */
1514 /* #### (the reader also loses on it) */
1515 Lisp_String *name = symbol_name(XSYMBOL(obj));
1516 Bytecount size = string_length(name);
1517 struct gcpro gcpro1, gcpro2;
1520 /* This deals with GC-relocation */
1521 Lisp_Object nameobj;
1522 XSETSTRING(nameobj, name);
1523 output_string(printcharfun, 0, nameobj, 0, size);
1526 GCPRO2(obj, printcharfun);
1528 /* If we print an uninterned symbol as part of a complex object and
1529 the flag print-gensym is non-nil, prefix it with #n= to read the
1530 object back with the #n# reader syntax later if needed. */
1531 if (!NILP(Vprint_gensym)
1532 /* #### Test whether this produces a noticeable slow-down for
1533 printing when print-gensym is non-nil. */
1534 && !EQ(obj, oblookup(Vobarray,
1535 string_data(symbol_name(XSYMBOL(obj))),
1536 string_length(symbol_name(XSYMBOL(obj)))))) {
1537 if (print_depth > 1) {
1538 Lisp_Object tem = Fassq(obj, Vprint_gensym_alist);
1540 write_char_internal("#", printcharfun);
1541 print_internal(XCDR(tem), printcharfun,
1543 write_char_internal("#", printcharfun);
1547 if (CONSP(Vprint_gensym_alist)) {
1548 /* Vprint_gensym_alist is exposed to Lisp, so we
1549 have to be careful. */
1550 CHECK_CONS(XCAR(Vprint_gensym_alist));
1552 (XCAR(Vprint_gensym_alist)));
1556 (Vprint_gensym_alist))) +
1560 Vprint_gensym_alist =
1561 Fcons(Fcons(obj, tem), Vprint_gensym_alist);
1563 write_char_internal("#", printcharfun);
1564 print_internal(tem, printcharfun, escapeflag);
1565 write_char_internal("=", printcharfun);
1568 write_c_string("#:", printcharfun);
1571 /* Does it look like an integer or a float? */
1573 Bufbyte *data = string_data(name);
1574 Bytecount confusing = 0;
1577 goto not_yet_confused; /* Really confusing */
1578 else if (isdigit(data[0]))
1581 goto not_yet_confused;
1582 else if (data[0] == '-' || data[0] == '+')
1585 goto not_yet_confused;
1587 for (; confusing < size; confusing++) {
1588 if (!isdigit(data[confusing])) {
1597 /* #### Ugh, this is needlessly complex and slow for what we
1598 need here. It might be a good idea to copy equivalent code
1599 from FSF. --hniksic */
1600 confusing = isfloat_string((char *)data);
1603 write_char_internal("\\", printcharfun);
1607 Lisp_Object nameobj;
1611 XSETSTRING(nameobj, name);
1612 for (i = 0; i < size; i++) {
1613 switch (string_byte(name, i)) {
1661 output_string(printcharfun, 0, nameobj,
1663 write_char_internal("\\", printcharfun);
1669 output_string(printcharfun, 0, nameobj, last, size - last);
1674 /* Useful on systems or in places where writing to stdout is unavailable or
1677 static int alternate_do_pointer;
1678 static char alternate_do_string[5000];
1680 DEFUN("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0, /*
1681 Append CHARACTER to the array `alternate_do_string'.
1682 This can be used in place of `external-debugging-output' as a function
1683 to be passed to `print'. Before calling `print', set `alternate_do_pointer'
1688 Bufbyte str[MAX_EMCHAR_LEN];
1691 const Extbyte *extptr;
1693 CHECK_CHAR_COERCE_INT(character);
1694 len = set_charptr_emchar(str, XCHAR(character));
1695 TO_EXTERNAL_FORMAT(DATA, (str, len),
1696 ALLOCA, (extptr, extlen), Qterminal);
1697 memcpy(alternate_do_string + alternate_do_pointer, extptr, extlen);
1698 alternate_do_pointer += extlen;
1699 alternate_do_string[alternate_do_pointer] = 0;
1703 DEFUN("external-debugging-output", Fexternal_debugging_output, 1, 3, 0, /*
1704 Write CHAR-OR-STRING to stderr or stdout.
1705 If optional arg STDOUT-P is non-nil, write to stdout; otherwise, write
1706 to stderr. You can use this function to write directly to the terminal.
1707 This function can be used as the STREAM argument of Fprint() or the like.
1709 Under MS Windows, this writes output to the console window (which is
1710 created, if necessary), unless SXEmacs is being run noninteractively
1711 \(i.e. using the `-batch' argument).
1713 If you have opened a termscript file (using `open-termscript'), then
1714 the output also will be logged to this file.
1716 (char_or_string, stdout_p, device))
1719 struct console *con = 0;
1722 if (!NILP(stdout_p))
1727 CHECK_LIVE_DEVICE(device);
1728 if (!DEVICE_TTY_P(XDEVICE(device)) &&
1729 !DEVICE_STREAM_P(XDEVICE(device)))
1730 signal_simple_error("Must be tty or stream device",
1732 con = XCONSOLE(DEVICE_CONSOLE(XDEVICE(device)));
1733 if (DEVICE_TTY_P(XDEVICE(device))) {
1735 } else if (!NILP(stdout_p)) {
1736 file = CONSOLE_STREAM_DATA(con)->out;
1738 file = CONSOLE_STREAM_DATA(con)->err;
1742 if (STRINGP(char_or_string))
1743 write_string_to_stdio_stream(file, con,
1744 XSTRING_DATA(char_or_string),
1745 0, XSTRING_LENGTH(char_or_string),
1748 Bufbyte str[MAX_EMCHAR_LEN];
1751 CHECK_CHAR_COERCE_INT(char_or_string);
1752 len = set_charptr_emchar(str, XCHAR(char_or_string));
1753 write_string_to_stdio_stream(file, con, str, 0, len, Qterminal,
1757 return char_or_string;
1760 DEFUN("open-termscript", Fopen_termscript, 1, 1, "FOpen termscript file: ", /*
1761 Start writing all terminal output to FILENAME as well as the terminal.
1762 FILENAME = nil means just close any termscript file currently open.
1766 /* This function can GC */
1767 if (termscript != 0) {
1772 if (!NILP(filename)) {
1773 filename = Fexpand_file_name(filename, Qnil);
1774 termscript = fopen((char *)XSTRING_DATA(filename), "w");
1775 if (termscript == NULL)
1776 report_file_error("Opening termscript",
1783 /* Debugging kludge -- unbuffered */
1784 static int debug_print_length = 50;
1785 static int debug_print_level = 15;
1786 static int debug_print_readably = -1;
1788 static void debug_print_no_newline(Lisp_Object debug_print_obj)
1790 /* This function can GC */
1791 int save_print_readably = print_readably;
1792 int save_print_depth = print_depth;
1793 Lisp_Object save_Vprint_length = Vprint_length;
1794 Lisp_Object save_Vprint_level = Vprint_level;
1795 Lisp_Object save_Vinhibit_quit = Vinhibit_quit;
1796 struct gcpro gcpro1, gcpro2, gcpro3;
1797 GCPRO3(save_Vprint_level, save_Vprint_length, save_Vinhibit_quit);
1801 ("** gc-in-progress! Bad idea to print anything! **\n");
1804 print_readably = debug_print_readably != -1 ? debug_print_readably : 0;
1806 inhibit_non_essential_printing_operations = 1;
1807 /* Could use unwind-protect, but why bother? */
1808 if (debug_print_length > 0)
1809 Vprint_length = make_int(debug_print_length);
1810 if (debug_print_level > 0)
1811 Vprint_level = make_int(debug_print_level);
1813 print_internal(debug_print_obj, Qexternal_debugging_output, 1);
1814 alternate_do_pointer = 0;
1815 print_internal(debug_print_obj, Qalternate_debugging_output, 1);
1817 Vinhibit_quit = save_Vinhibit_quit;
1818 Vprint_level = save_Vprint_level;
1819 Vprint_length = save_Vprint_length;
1820 print_depth = save_print_depth;
1821 print_readably = save_print_readably;
1822 inhibit_non_essential_printing_operations = 0;
1827 void debug_print(Lisp_Object debug_print_obj)
1829 debug_print_no_newline(debug_print_obj);
1833 /* Debugging kludge -- unbuffered */
1834 /* This function provided for the benefit of the debugger. */
1835 void debug_backtrace(void);
1836 void debug_backtrace(void)
1838 /* This function can GC */
1839 int old_print_readably = print_readably;
1840 int old_print_depth = print_depth;
1841 Lisp_Object old_print_length = Vprint_length;
1842 Lisp_Object old_print_level = Vprint_level;
1843 Lisp_Object old_inhibit_quit = Vinhibit_quit;
1845 struct gcpro gcpro1, gcpro2, gcpro3;
1846 GCPRO3(old_print_level, old_print_length, old_inhibit_quit);
1850 ("** gc-in-progress! Bad idea to print anything! **\n");
1855 inhibit_non_essential_printing_operations = 1;
1856 /* Could use unwind-protect, but why bother? */
1857 if (debug_print_length > 0)
1858 Vprint_length = make_int(debug_print_length);
1859 if (debug_print_level > 0)
1860 Vprint_level = make_int(debug_print_level);
1862 Fbacktrace(Qexternal_debugging_output, Qt);
1865 Vinhibit_quit = old_inhibit_quit;
1866 Vprint_level = old_print_level;
1867 Vprint_length = old_print_length;
1868 print_depth = old_print_depth;
1869 print_readably = old_print_readably;
1870 inhibit_non_essential_printing_operations = 0;
1876 void debug_short_backtrace(int length)
1879 struct backtrace *bt = backtrace_list;
1881 while (length > 0 && bt) {
1885 if (COMPILED_FUNCTIONP(*bt->function)) {
1886 #if defined(COMPILED_FUNCTION_ANNOTATION_HACK)
1888 compiled_function_annotation(XCOMPILED_FUNCTION
1891 Lisp_Object ann = Qnil;
1894 stderr_out("<compiled-function from ");
1895 debug_print_no_newline(ann);
1899 ("<compiled-function of unknown origin>");
1902 debug_print_no_newline(*bt->function);
1910 #endif /* debugging kludge */
1912 void syms_of_print(void)
1914 defsymbol(&Qstandard_output, "standard-output");
1916 defsymbol(&Qprint_length, "print-length");
1918 defsymbol(&Qprint_string_length, "print-string-length");
1920 defsymbol(&Qdisplay_error, "display-error");
1921 defsymbol(&Qprint_message_label, "print-message-label");
1924 DEFSUBR(Fprin1_to_string);
1927 DEFSUBR(Ferror_message_string);
1928 DEFSUBR(Fdisplay_error);
1930 DEFSUBR(Fwrite_char);
1931 DEFSUBR(Falternate_debugging_output);
1932 DEFSUBR(Fexternal_debugging_output);
1933 DEFSUBR(Fopen_termscript);
1934 defsymbol(&Qexternal_debugging_output, "external-debugging-output");
1935 defsymbol(&Qalternate_debugging_output, "alternate-debugging-output");
1936 DEFSUBR(Fwith_output_to_temp_buffer);
1939 void reinit_vars_of_print(void)
1941 alternate_do_pointer = 0;
1944 void vars_of_print(void)
1946 reinit_vars_of_print();
1948 DEFVAR_LISP("standard-output", &Vstandard_output /*
1949 Output stream `print' uses by default for outputting a character.
1950 This may be any function of one argument.
1951 It may also be a buffer (output is inserted before point)
1952 or a marker (output is inserted and the marker is advanced)
1953 or the symbol t (output appears in the minibuffer line).
1955 Vstandard_output = Qt;
1958 DEFVAR_LISP("float-output-format", &Vfloat_output_format /*
1959 The format descriptor string that lisp uses to print floats.
1960 This is a %-spec like those accepted by `printf' in C,
1961 but with some restrictions. It must start with the two characters `%.'.
1962 After that comes an integer precision specification,
1963 and then a letter which controls the format.
1964 The letters allowed are `e', `f' and `g'.
1965 Use `e' for exponential notation "DIG.DIGITSeEXPT"
1966 Use `f' for decimal point notation "DIGITS.DIGITS".
1967 Use `g' to choose the shorter of those two formats for the number at hand.
1968 The precision in any of these cases is the number of digits following
1969 the decimal point. With `f', a precision of 0 means to omit the
1970 decimal point. 0 is not allowed with `f' or `g'.
1972 A value of nil means to use `%.16g'.
1974 Regardless of the value of `float-output-format', a floating point number
1975 will never be printed in such a way that it is ambiguous with an integer;
1976 that is, a floating-point number will always be printed with a decimal
1977 point and/or an exponent, even if the digits following the decimal point
1978 are all zero. This is to preserve read-equivalence.
1980 Vfloat_output_format = Qnil;
1981 #endif /* HAVE_FPFLOAT */
1983 DEFVAR_LISP("print-length", &Vprint_length /*
1984 Maximum length of list or vector to print before abbreviating.
1985 A value of nil means no limit.
1987 Vprint_length = Qnil;
1989 DEFVAR_LISP("print-string-length", &Vprint_string_length /*
1990 Maximum length of string to print before abbreviating.
1991 A value of nil means no limit.
1993 Vprint_string_length = Qnil;
1995 DEFVAR_LISP("print-level", &Vprint_level /*
1996 Maximum depth of list nesting to print before abbreviating.
1997 A value of nil means no limit.
1999 Vprint_level = Qnil;
2001 DEFVAR_BOOL("print-escape-newlines", &print_escape_newlines /*
2002 Non-nil means print newlines in strings as backslash-n.
2004 print_escape_newlines = 0;
2006 DEFVAR_BOOL("print-readably", &print_readably /*
2007 If non-nil, then all objects will be printed in a readable form.
2008 If an object has no readable representation, then an error is signalled.
2009 When print-readably is true, compiled-function objects will be written in
2010 #[...] form instead of in #<compiled-function [...]> form, and two-element
2011 lists of the form (quote object) will be written as the equivalent 'object.
2012 Do not SET this variable; bind it instead.
2016 /* #### I think this should default to t. But we'd better wait
2017 until we see that it works out. */
2018 DEFVAR_LISP("print-gensym", &Vprint_gensym /*
2019 If non-nil, then uninterned symbols will be printed specially.
2020 Uninterned symbols are those which are not present in `obarray', that is,
2021 those which were made with `make-symbol' or by calling `intern' with a
2024 When print-gensym is true, such symbols will be preceded by "#:",
2025 which causes the reader to create a new symbol instead of interning
2026 and returning an existing one. Beware: the #: syntax creates a new
2027 symbol each time it is seen, so if you print an object which contains
2028 two pointers to the same uninterned symbol, `read' will not duplicate
2031 If the value of `print-gensym' is a cons cell, then in addition
2032 refrain from clearing `print-gensym-alist' on entry to and exit from
2033 printing functions, so that the use of #...# and #...= can carry over
2034 for several separately printed objects.
2036 Vprint_gensym = Qnil;
2038 DEFVAR_LISP("print-gensym-alist", &Vprint_gensym_alist /*
2039 Association list of elements (GENSYM . N) to guide use of #N# and #N=.
2040 In each element, GENSYM is an uninterned symbol that has been associated
2041 with #N= for the specified value of N.
2043 Vprint_gensym_alist = Qnil;
2045 DEFVAR_LISP("print-message-label", &Vprint_message_label /*
2046 Label for minibuffer messages created with `print'. This should
2047 generally be bound with `let' rather than set. (See `display-message'.)
2049 Vprint_message_label = Qprint;
2051 DEFVAR_LISP("custom-object-printer", &Vcustom_object_printer /*
2052 Function to call in order to print custom object.
2054 Vcustom_object_printer = Qnil;