X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/3e9bc90131b09b6820e6cebf003a0642b9c4eb97..0872e11f1595845e7f3ba2c0d8e53ec7fc0f49e3:/src/print.c diff --git a/src/print.c b/src/print.c index b07b770dad..6ac2b25745 100644 --- a/src/print.c +++ b/src/print.c @@ -1,5 +1,5 @@ /* Lisp object printing and output streams. - Copyright (C) 1985, 1986, 1988, 1993, 1994 Free Software Foundation, Inc. + Copyright (C) 1985, 86, 88, 93, 94, 95 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -15,21 +15,23 @@ GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Emacs; see the file COPYING. If not, write to -the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ #include #include -#undef NULL #include "lisp.h" #ifndef standalone #include "buffer.h" +#include "charset.h" #include "frame.h" #include "window.h" #include "process.h" #include "dispextern.h" #include "termchar.h" +#include "keyboard.h" #endif /* not standalone */ #ifdef USE_TEXT_PROPERTIES @@ -38,6 +40,9 @@ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ Lisp_Object Vstandard_output, Qstandard_output; +/* These are used to print like we read. */ +extern Lisp_Object Qbackquote, Qcomma, Qcomma_at, Qcomma_dot, Qfunction; + #ifdef LISP_FLOAT_TYPE Lisp_Object Vfloat_output_format, Qfloat_output_format; #endif /* LISP_FLOAT_TYPE */ @@ -49,6 +54,15 @@ int print_depth; #define PRINT_CIRCLE 200 Lisp_Object being_printed[PRINT_CIRCLE]; +/* When printing into a buffer, first we put the text in this + block, then insert it all at once. */ +char *print_buffer; + +/* Size allocated in print_buffer. */ +int print_buffer_size; +/* Size used in print_buffer. */ +int print_buffer_pos; + /* Maximum length of list to print in full; noninteger means effectively infinity */ @@ -65,10 +79,25 @@ int print_escape_newlines; Lisp_Object Qprint_escape_newlines; -/* Nonzero means print newline before next minibuffer message. +/* Nonzero means print (quote foo) forms as 'foo, etc. */ + +int print_quoted; + +/* Nonzero means print #: before uninterned symbols. */ + +int print_gensym; + +/* Association list of certain objects that are `eq' in the form being + printed and which should be `eq' when read back in, using the #n=object + and #n# reader forms. Each element has the form (object . n). */ + +Lisp_Object printed_gensyms; + +/* Nonzero means print newline to stdout before next minibuffer message. Defined in xdisp.c */ extern int noninteractive_need_newline; + #ifdef MAX_PRINT_CHARS static int print_chars; static int max_print; @@ -131,50 +160,98 @@ glyph_to_str_cpy (glyphs, str) /* Low level output routines for characters and strings */ /* Lisp functions to do output using a stream - must have the stream in a variable called printcharfun - and must start with PRINTPREPARE and end with PRINTFINISH. - Use PRINTCHAR to output one character, - or call strout to output a block of characters. - Also, each one must have the declarations - struct buffer *old = current_buffer; - int old_point = -1, start_point; - Lisp_Object original; + must have the stream in a variable called printcharfun + and must start with PRINTPREPARE, end with PRINTFINISH, + and use PRINTDECLARE to declare common variables. + Use PRINTCHAR to output one character, + or call strout to output a block of characters. */ +#define PRINTDECLARE \ + struct buffer *old = current_buffer; \ + int old_point = -1, start_point; \ + int specpdl_count = specpdl_ptr - specpdl; \ + int free_print_buffer = 0; \ + Lisp_Object original + #define PRINTPREPARE \ original = printcharfun; \ if (NILP (printcharfun)) printcharfun = Qt; \ if (BUFFERP (printcharfun)) \ - { if (XBUFFER (printcharfun) != current_buffer) \ + { \ + if (XBUFFER (printcharfun) != current_buffer) \ Fset_buffer (printcharfun); \ - printcharfun = Qnil;} \ + printcharfun = Qnil; \ + } \ if (MARKERP (printcharfun)) \ - { if (!(XMARKER (original)->buffer)) \ + { \ + if (!(XMARKER (original)->buffer)) \ error ("Marker does not point anywhere"); \ if (XMARKER (original)->buffer != current_buffer) \ set_buffer_internal (XMARKER (original)->buffer); \ - old_point = point; \ + old_point = PT; \ SET_PT (marker_position (printcharfun)); \ - start_point = point; \ - printcharfun = Qnil;} + start_point = PT; \ + printcharfun = Qnil; \ + } \ + if (NILP (printcharfun)) \ + { \ + if (print_buffer != 0) \ + record_unwind_protect (print_unwind, \ + make_string (print_buffer, \ + print_buffer_pos)); \ + else \ + { \ + print_buffer_size = 1000; \ + print_buffer = (char *) xmalloc (print_buffer_size); \ + free_print_buffer = 1; \ + } \ + print_buffer_pos = 0; \ + } \ + printed_gensyms = Qnil #define PRINTFINISH \ + if (NILP (printcharfun)) \ + insert (print_buffer, print_buffer_pos); \ + if (free_print_buffer) \ + { \ + xfree (print_buffer); \ + print_buffer = 0; \ + } \ + unbind_to (specpdl_count, Qnil); \ if (MARKERP (original)) \ - Fset_marker (original, make_number (point), Qnil); \ + Fset_marker (original, make_number (PT), Qnil); \ if (old_point >= 0) \ SET_PT (old_point + (old_point >= start_point \ - ? point - start_point : 0)); \ + ? PT - start_point : 0)); \ if (old != current_buffer) \ - set_buffer_internal (old) + set_buffer_internal (old); \ + printed_gensyms = Qnil #define PRINTCHAR(ch) printchar (ch, printcharfun) -/* Index of first unused element of FRAME_MESSAGE_BUF(mini_frame). */ +/* Nonzero if there is no room to print any more characters + so print might as well return right away. */ + +#define PRINTFULLP() \ + (EQ (printcharfun, Qt) && !noninteractive \ + && printbufidx >= FRAME_WIDTH (XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window))))) + +/* This is used to restore the saved contents of print_buffer + when there is a recursive call to print. */ +static Lisp_Object +print_unwind (saved_text) + Lisp_Object saved_text; +{ + bcopy (XSTRING (saved_text)->data, print_buffer, XSTRING (saved_text)->size); +} + +/* Index of first unused element of FRAME_MESSAGE_BUF (mini_frame). */ static int printbufidx; static void printchar (ch, fun) - unsigned char ch; + unsigned int ch; Lisp_Object fun; { Lisp_Object ch1; @@ -186,8 +263,16 @@ printchar (ch, fun) #ifndef standalone if (EQ (fun, Qnil)) { + int len; + char work[4], *str; + QUIT; - insert (&ch, 1); + len = CHAR_STRING (ch, work, str); + if (print_buffer_pos + len >= print_buffer_size) + print_buffer = (char *) xrealloc (print_buffer, + print_buffer_size *= 2); + bcopy (str, print_buffer + print_buffer_pos, len); + print_buffer_pos += len; return; } @@ -195,10 +280,15 @@ printchar (ch, fun) { FRAME_PTR mini_frame = XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window))); + unsigned char work[4], *str; + int len = CHAR_STRING (ch, work, str); + + QUIT; if (noninteractive) { - putchar (ch); + while (len--) + putchar (*str), str++; noninteractive_need_newline = 1; return; } @@ -206,14 +296,17 @@ printchar (ch, fun) if (echo_area_glyphs != FRAME_MESSAGE_BUF (mini_frame) || !message_buf_print) { + message_log_maybe_newline (); echo_area_glyphs = FRAME_MESSAGE_BUF (mini_frame); printbufidx = 0; echo_area_glyphs_length = 0; message_buf_print = 1; } - if (printbufidx < FRAME_WIDTH (mini_frame) - 1) - FRAME_MESSAGE_BUF (mini_frame)[printbufidx++] = ch; + message_dolog (str, len, 0); + if (printbufidx < FRAME_MESSAGE_BUF_SIZE (mini_frame) - len) + bcopy (str, &FRAME_MESSAGE_BUF (mini_frame)[printbufidx], len), + printbufidx += len; FRAME_MESSAGE_BUF (mini_frame)[printbufidx] = 0; echo_area_glyphs_length = printbufidx; @@ -233,12 +326,23 @@ strout (ptr, size, printcharfun) { int i = 0; + if (size < 0) + size = strlen (ptr); + if (EQ (printcharfun, Qnil)) { - insert (ptr, size >= 0 ? size : strlen (ptr)); + if (print_buffer_pos + size > print_buffer_size) + { + print_buffer_size = print_buffer_size * 2 + size; + print_buffer = (char *) xrealloc (print_buffer, + print_buffer_size); + } + bcopy (ptr, print_buffer + print_buffer_pos, size); + print_buffer_pos += size; + #ifdef MAX_PRINT_CHARS if (max_print) - print_chars += size >= 0 ? size : strlen(ptr); + print_chars += size; #endif /* MAX_PRINT_CHARS */ return; } @@ -247,15 +351,16 @@ strout (ptr, size, printcharfun) FRAME_PTR mini_frame = XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window))); - i = size >= 0 ? size : strlen (ptr); + QUIT; + #ifdef MAX_PRINT_CHARS if (max_print) - print_chars += i; + print_chars += size; #endif /* MAX_PRINT_CHARS */ if (noninteractive) { - fwrite (ptr, 1, i, stdout); + fwrite (ptr, 1, size, stdout); noninteractive_need_newline = 1; return; } @@ -263,39 +368,51 @@ strout (ptr, size, printcharfun) if (echo_area_glyphs != FRAME_MESSAGE_BUF (mini_frame) || !message_buf_print) { + message_log_maybe_newline (); echo_area_glyphs = FRAME_MESSAGE_BUF (mini_frame); printbufidx = 0; echo_area_glyphs_length = 0; message_buf_print = 1; } - if (i > FRAME_WIDTH (mini_frame) - printbufidx - 1) - i = FRAME_WIDTH (mini_frame) - printbufidx - 1; - bcopy (ptr, &FRAME_MESSAGE_BUF (mini_frame) [printbufidx], i); - printbufidx += i; + message_dolog (ptr, size, 0); + if (size > FRAME_MESSAGE_BUF_SIZE (mini_frame) - printbufidx - 1) + { + size = FRAME_MESSAGE_BUF_SIZE (mini_frame) - printbufidx - 1; + /* Rewind incomplete multi-byte form. */ + while (size && (unsigned char) ptr[size] >= 0xA0) size--; + } + bcopy (ptr, &FRAME_MESSAGE_BUF (mini_frame) [printbufidx], size); + printbufidx += size; echo_area_glyphs_length = printbufidx; FRAME_MESSAGE_BUF (mini_frame) [printbufidx] = 0; return; } - if (size >= 0) - while (i < size) - PRINTCHAR (ptr[i++]); - else - while (ptr[i]) - PRINTCHAR (ptr[i++]); + i = 0; + while (i < size) + { + /* Here, we must convert each multi-byte form to the + corresponding character code before handing it to PRINTCHAR. */ + int len; + int ch = STRING_CHAR_AND_LENGTH (ptr + i, size - i, len); + + PRINTCHAR (ch); + i += len; + } } /* Print the contents of a string STRING using PRINTCHARFUN. - It isn't safe to use strout, because printing one char can relocate. */ + It isn't safe to use strout in many cases, + because printing one char can relocate. */ print_string (string, printcharfun) Lisp_Object string; Lisp_Object printcharfun; { - if (EQ (printcharfun, Qnil) || EQ (printcharfun, Qt)) - /* In predictable cases, strout is safe: output to buffer or frame. */ + if (EQ (printcharfun, Qt) || NILP (printcharfun)) + /* strout is safe for output to a frame (echo area) or to print_buffer. */ strout (XSTRING (string)->data, XSTRING (string)->size, printcharfun); else { @@ -311,23 +428,20 @@ print_string (string, printcharfun) } DEFUN ("write-char", Fwrite_char, Swrite_char, 1, 2, 0, - "Output character CHAR to stream PRINTCHARFUN.\n\ + "Output character CHARACTER to stream PRINTCHARFUN.\n\ PRINTCHARFUN defaults to the value of `standard-output' (which see).") - (ch, printcharfun) - Lisp_Object ch, printcharfun; + (character, printcharfun) + Lisp_Object character, printcharfun; { - struct buffer *old = current_buffer; - int old_point = -1; - int start_point; - Lisp_Object original; + PRINTDECLARE; if (NILP (printcharfun)) printcharfun = Vstandard_output; - CHECK_NUMBER (ch, 0); + CHECK_NUMBER (character, 0); PRINTPREPARE; - PRINTCHAR (XINT (ch)); + PRINTCHAR (XINT (character)); PRINTFINISH; - return ch; + return character; } /* Used from outside of print.c to print a block of SIZE chars at DATA @@ -338,11 +452,8 @@ write_string (data, size) char *data; int size; { - struct buffer *old = current_buffer; + PRINTDECLARE; Lisp_Object printcharfun; - int old_point = -1; - int start_point; - Lisp_Object original; printcharfun = Vstandard_output; @@ -360,10 +471,7 @@ write_string_1 (data, size, printcharfun) int size; Lisp_Object printcharfun; { - struct buffer *old = current_buffer; - int old_point = -1; - int start_point; - Lisp_Object original; + PRINTDECLARE; PRINTPREPARE; strout (data, size, printcharfun); @@ -382,6 +490,7 @@ temp_output_buffer_setup (bufname) Fset_buffer (Fget_buffer_create (build_string (bufname))); + current_buffer->directory = old->directory; current_buffer->read_only = Qnil; Ferase_buffer (); @@ -458,10 +567,7 @@ If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used.") (printcharfun) Lisp_Object printcharfun; { - struct buffer *old = current_buffer; - int old_point = -1; - int start_point; - Lisp_Object original; + PRINTDECLARE; if (NILP (printcharfun)) printcharfun = Vstandard_output; @@ -476,13 +582,10 @@ DEFUN ("prin1", Fprin1, Sprin1, 1, 2, 0, Quoting characters are printed when needed to make output that `read'\n\ can handle, whenever this is possible.\n\ Output stream is PRINTCHARFUN, or value of `standard-output' (which see).") - (obj, printcharfun) - Lisp_Object obj, printcharfun; + (object, printcharfun) + Lisp_Object object, printcharfun; { - struct buffer *old = current_buffer; - int old_point = -1; - int start_point; - Lisp_Object original; + PRINTDECLARE; #ifdef MAX_PRINT_CHARS max_print = 0; @@ -491,9 +594,9 @@ Output stream is PRINTCHARFUN, or value of `standard-output' (which see).") printcharfun = Vstandard_output; PRINTPREPARE; print_depth = 0; - print (obj, printcharfun, 1); + print (object, printcharfun, 1); PRINTFINISH; - return obj; + return object; } /* a buffer which is used to hold output being built by prin1-to-string */ @@ -504,30 +607,36 @@ DEFUN ("prin1-to-string", Fprin1_to_string, Sprin1_to_string, 1, 2, 0, any Lisp object. Quoting characters are used when needed to make output\n\ that `read' can handle, whenever this is possible, unless the optional\n\ second argument NOESCAPE is non-nil.") - (obj, noescape) - Lisp_Object obj, noescape; + (object, noescape) + Lisp_Object object, noescape; { - struct buffer *old = current_buffer; - int old_point = -1; - int start_point; - Lisp_Object original, printcharfun; - struct gcpro gcpro1; + PRINTDECLARE; + Lisp_Object printcharfun; + struct gcpro gcpro1, gcpro2; + Lisp_Object tem; + + /* Save and restore this--we are altering a buffer + but we don't want to deactivate the mark just for that. + No need for specbind, since errors deactivate the mark. */ + tem = Vdeactivate_mark; + GCPRO2 (object, tem); printcharfun = Vprin1_to_string_buffer; PRINTPREPARE; print_depth = 0; - print (obj, printcharfun, NILP (noescape)); + print (object, printcharfun, NILP (noescape)); /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */ PRINTFINISH; set_buffer_internal (XBUFFER (Vprin1_to_string_buffer)); - obj = Fbuffer_string (); + object = Fbuffer_string (); - GCPRO1 (obj); Ferase_buffer (); set_buffer_internal (old); + + Vdeactivate_mark = tem; UNGCPRO; - return obj; + return object; } DEFUN ("princ", Fprinc, Sprinc, 1, 2, 0, @@ -535,21 +644,18 @@ DEFUN ("princ", Fprinc, Sprinc, 1, 2, 0, No quoting characters are used; no delimiters are printed around\n\ the contents of strings.\n\ Output stream is PRINTCHARFUN, or value of standard-output (which see).") - (obj, printcharfun) - Lisp_Object obj, printcharfun; + (object, printcharfun) + Lisp_Object object, printcharfun; { - struct buffer *old = current_buffer; - int old_point = -1; - int start_point; - Lisp_Object original; + PRINTDECLARE; if (NILP (printcharfun)) printcharfun = Vstandard_output; PRINTPREPARE; print_depth = 0; - print (obj, printcharfun, 0); + print (object, printcharfun, 0); PRINTFINISH; - return obj; + return object; } DEFUN ("print", Fprint, Sprint, 1, 2, 0, @@ -557,13 +663,10 @@ DEFUN ("print", Fprint, Sprint, 1, 2, 0, Quoting characters are printed when needed to make output that `read'\n\ can handle, whenever this is possible.\n\ Output stream is PRINTCHARFUN, or value of `standard-output' (which see).") - (obj, printcharfun) - Lisp_Object obj, printcharfun; + (object, printcharfun) + Lisp_Object object, printcharfun; { - struct buffer *old = current_buffer; - int old_point = -1; - int start_point; - Lisp_Object original; + PRINTDECLARE; struct gcpro gcpro1; #ifdef MAX_PRINT_CHARS @@ -572,11 +675,11 @@ Output stream is PRINTCHARFUN, or value of `standard-output' (which see).") #endif /* MAX_PRINT_CHARS */ if (NILP (printcharfun)) printcharfun = Vstandard_output; - GCPRO1 (obj); + GCPRO1 (object); PRINTPREPARE; print_depth = 0; PRINTCHAR ('\n'); - print (obj, printcharfun, 1); + print (object, printcharfun, 1); PRINTCHAR ('\n'); PRINTFINISH; #ifdef MAX_PRINT_CHARS @@ -584,7 +687,7 @@ Output stream is PRINTCHARFUN, or value of `standard-output' (which see).") print_chars = 0; #endif /* MAX_PRINT_CHARS */ UNGCPRO; - return obj; + return object; } /* The subroutine object for external-debugging-output is kept here @@ -611,13 +714,98 @@ debug_print (arg) Lisp_Object arg; { Fprin1 (arg, Qexternal_debugging_output); + fprintf (stderr, "\r\n"); +} + +DEFUN ("error-message-string", Ferror_message_string, Serror_message_string, + 1, 1, 0, + "Convert an error value (ERROR-SYMBOL . DATA) to an error message.") + (obj) + Lisp_Object obj; +{ + struct buffer *old = current_buffer; + Lisp_Object original, printcharfun, value; + struct gcpro gcpro1; + + /* If OBJ is (error STRING), just return STRING. + That is not only faster, it also avoids the need to allocate + space here when the error is due to memory full. */ + if (CONSP (obj) && EQ (XCONS (obj)->car, Qerror) + && CONSP (XCONS (obj)->cdr) + && STRINGP (XCONS (XCONS (obj)->cdr)->car) + && NILP (XCONS (XCONS (obj)->cdr)->cdr)) + return XCONS (XCONS (obj)->cdr)->car; + + print_error_message (obj, Vprin1_to_string_buffer, NULL); + + set_buffer_internal (XBUFFER (Vprin1_to_string_buffer)); + value = Fbuffer_string (); + + GCPRO1 (value); + Ferase_buffer (); + set_buffer_internal (old); + UNGCPRO; + + return value; +} + +/* Print an error message for the error DATA + onto Lisp output stream STREAM (suitable for the print functions). */ + +print_error_message (data, stream) + Lisp_Object data, stream; +{ + Lisp_Object errname, errmsg, file_error, tail; + struct gcpro gcpro1; + int i; + + errname = Fcar (data); + + if (EQ (errname, Qerror)) + { + data = Fcdr (data); + if (!CONSP (data)) data = Qnil; + errmsg = Fcar (data); + file_error = Qnil; + } + else + { + errmsg = Fget (errname, Qerror_message); + file_error = Fmemq (Qfile_error, + Fget (errname, Qerror_conditions)); + } + + /* Print an error message including the data items. */ + + tail = Fcdr_safe (data); + GCPRO1 (tail); + + /* For file-error, make error message by concatenating + all the data items. They are all strings. */ + if (!NILP (file_error) && !NILP (tail)) + errmsg = XCONS (tail)->car, tail = XCONS (tail)->cdr; + + if (STRINGP (errmsg)) + Fprinc (errmsg, stream); + else + write_string_1 ("peculiar error", -1, stream); + + for (i = 0; CONSP (tail); tail = Fcdr (tail), i++) + { + write_string_1 (i ? ", " : ": ", 2, stream); + if (!NILP (file_error)) + Fprinc (Fcar (tail), stream); + else + Fprin1 (Fcar (tail), stream); + } + UNGCPRO; } #ifdef LISP_FLOAT_TYPE /* * The buffer should be at least as large as the max string size of the - * largest float, printed in the biggest notation. This is undoubtably + * largest float, printed in the biggest notation. This is undoubtedly * 20d float_output_format, with the negative of the C-constant "HUGE" * from . * @@ -661,19 +849,21 @@ float_to_string (buf, data) /* Check the width specification. */ width = -1; if ('0' <= *cp && *cp <= '9') - for (width = 0; (*cp >= '0' && *cp <= '9'); cp++) - width = (width * 10) + (*cp - '0'); + { + width = 0; + do + width = (width * 10) + (*cp++ - '0'); + while (*cp >= '0' && *cp <= '9'); + + /* A precision of zero is valid only for %f. */ + if (width > DBL_DIG + || (width == 0 && *cp != 'f')) + goto lose; + } if (*cp != 'e' && *cp != 'f' && *cp != 'g') goto lose; - /* A precision of zero is valid for %f; everything else requires - at least one. Width may be omitted anywhere. */ - if (width != -1 - && (width < (*cp != 'f') - || width > DBL_DIG)) - goto lose; - if (cp[1] != 0) goto lose; @@ -745,20 +935,16 @@ print (obj, printcharfun, escapeflag) } #endif /* MAX_PRINT_CHARS */ -#ifdef SWITCH_ENUM_BUG - switch ((int) XTYPE (obj)) -#else - switch (XTYPE (obj)) -#endif + switch (XGCTYPE (obj)) { - default: - /* We're in trouble if this happens! - Probably should just abort () */ - strout ("#", - -1, printcharfun); break; #ifdef LISP_FLOAT_TYPE @@ -770,12 +956,7 @@ print (obj, printcharfun, escapeflag) strout (pigbuf, -1, printcharfun); } break; -#endif /* LISP_FLOAT_TYPE */ - - case Lisp_Int: - sprintf (buf, "%d", XINT (obj)); - strout (buf, -1, printcharfun); - break; +#endif case Lisp_String: if (!escapeflag) @@ -839,27 +1020,75 @@ print (obj, printcharfun, escapeflag) register unsigned char *p = XSYMBOL (obj)->name->data; register unsigned char *end = p + XSYMBOL (obj)->name->size; register unsigned char c; + int i; if (p != end && (*p == '-' || *p == '+')) p++; - if (p == end) + if (p == end) confusing = 0; - else + /* If symbol name begins with a digit, and ends with a digit, + and contains nothing but digits and `e', it could be treated + as a number. So set CONFUSING. + + Symbols that contain periods could also be taken as numbers, + but periods are always escaped, so we don't have to worry + about them here. */ + else if (*p >= '0' && *p <= '9' + && end[-1] >= '0' && end[-1] <= '9') { - while (p != end && *p >= '0' && *p <= '9') + while (p != end && ((*p >= '0' && *p <= '9') + /* Needed for \2e10. */ + || *p == 'e')) p++; confusing = (end == p); } + else + confusing = 0; - p = XSYMBOL (obj)->name->data; - while (p != end) + /* If we print an uninterned symbol as part of a complex object and + the flag print-gensym is non-nil, prefix it with #n= to read the + object back with the #n# reader syntax later if needed. */ + if (print_gensym && NILP (XSYMBOL (obj)->obarray)) + { + if (print_depth > 1) + { + Lisp_Object tem; + tem = Fassq (obj, printed_gensyms); + if (CONSP (tem)) + { + PRINTCHAR ('#'); + print (XCDR (tem), printcharfun, escapeflag); + PRINTCHAR ('#'); + break; + } + else + { + if (CONSP (printed_gensyms)) + XSETFASTINT (tem, XCDR (XCAR (printed_gensyms)) + 1); + else + XSETFASTINT (tem, 1); + printed_gensyms = Fcons (Fcons (obj, tem), printed_gensyms); + + PRINTCHAR ('#'); + print (tem, printcharfun, escapeflag); + PRINTCHAR ('='); + } + } + PRINTCHAR ('#'); + PRINTCHAR (':'); + } + + for (i = 0; i < XSYMBOL (obj)->name->size; i++) { QUIT; - c = *p++; + c = XSYMBOL (obj)->name->data[i]; + if (escapeflag) { - if (c == '\"' || c == '\\' || c == '\'' || c == ';' || c == '#' || - c == '(' || c == ')' || c == ',' || c =='.' || c == '`' || - c == '[' || c == ']' || c == '?' || c <= 040 || confusing) + if (c == '\"' || c == '\\' || c == '\'' + || c == ';' || c == '#' || c == '(' || c == ')' + || c == ',' || c =='.' || c == '`' + || c == '[' || c == ']' || c == '?' || c <= 040 + || confusing) PRINTCHAR ('\\'), confusing = 0; } PRINTCHAR (c); @@ -871,120 +1100,222 @@ print (obj, printcharfun, escapeflag) /* If deeper than spec'd depth, print placeholder. */ if (INTEGERP (Vprint_level) && print_depth > XINT (Vprint_level)) + strout ("...", -1, printcharfun); + else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj))) + && (EQ (XCAR (obj), Qquote))) { - strout ("...", -1, printcharfun); - break; + PRINTCHAR ('\''); + print (XCAR (XCDR (obj)), printcharfun, escapeflag); } - - PRINTCHAR ('('); - { - register int i = 0; - register int max = 0; - - if (INTEGERP (Vprint_length)) - max = XINT (Vprint_length); - /* Could recognize circularities in cdrs here, - but that would make printing of long lists quadratic. - It's not worth doing. */ - while (CONSP (obj)) + else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj))) + && (EQ (XCAR (obj), Qfunction))) + { + PRINTCHAR ('#'); + PRINTCHAR ('\''); + print (XCAR (XCDR (obj)), printcharfun, escapeflag); + } + else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj))) + && ((EQ (XCAR (obj), Qbackquote) + || EQ (XCAR (obj), Qcomma) + || EQ (XCAR (obj), Qcomma_at) + || EQ (XCAR (obj), Qcomma_dot)))) + { + print (XCAR (obj), printcharfun, 0); + print (XCAR (XCDR (obj)), printcharfun, escapeflag); + } + else + { + PRINTCHAR ('('); { - if (i++) - PRINTCHAR (' '); - if (max && i > max) + register int i = 0; + register int max = 0; + + if (INTEGERP (Vprint_length)) + max = XINT (Vprint_length); + /* Could recognize circularities in cdrs here, + but that would make printing of long lists quadratic. + It's not worth doing. */ + while (CONSP (obj)) { - strout ("...", 3, printcharfun); - break; + if (i++) + PRINTCHAR (' '); + if (max && i > max) + { + strout ("...", 3, printcharfun); + break; + } + print (XCAR (obj), printcharfun, escapeflag); + obj = XCDR (obj); } - print (Fcar (obj), printcharfun, escapeflag); - obj = Fcdr (obj); } - } - if (!NILP (obj) && !CONSP (obj)) - { - strout (" . ", 3, printcharfun); - print (obj, printcharfun, escapeflag); + if (!NILP (obj)) + { + strout (" . ", 3, printcharfun); + print (obj, printcharfun, escapeflag); + } + PRINTCHAR (')'); } - PRINTCHAR (')'); break; - case Lisp_Compiled: - strout ("#", -1, printcharfun); - case Lisp_Vector: - PRINTCHAR ('['); - { - register int i; - register Lisp_Object tem; - for (i = 0; i < XVECTOR (obj)->size; i++) - { - if (i) PRINTCHAR (' '); - tem = XVECTOR (obj)->contents[i]; - print (tem, printcharfun, escapeflag); - } - } - PRINTCHAR (']'); - break; + case Lisp_Vectorlike: + if (PROCESSP (obj)) + { + if (escapeflag) + { + strout ("#name, printcharfun); + PRINTCHAR ('>'); + } + else + print_string (XPROCESS (obj)->name, printcharfun); + } + else if (BOOL_VECTOR_P (obj)) + { + register int i; + register unsigned char c; + struct gcpro gcpro1; + int size_in_chars + = (XBOOL_VECTOR (obj)->size + BITS_PER_CHAR - 1) / BITS_PER_CHAR; + + GCPRO1 (obj); + + PRINTCHAR ('#'); + PRINTCHAR ('&'); + sprintf (buf, "%d", XBOOL_VECTOR (obj)->size); + strout (buf, -1, printcharfun); + PRINTCHAR ('\"'); + + /* Don't print more characters than the specified maximum. */ + if (INTEGERP (Vprint_length) + && XINT (Vprint_length) < size_in_chars) + size_in_chars = XINT (Vprint_length); + + for (i = 0; i < size_in_chars; i++) + { + QUIT; + c = XBOOL_VECTOR (obj)->data[i]; + if (c == '\n' && print_escape_newlines) + { + PRINTCHAR ('\\'); + PRINTCHAR ('n'); + } + else if (c == '\f' && print_escape_newlines) + { + PRINTCHAR ('\\'); + PRINTCHAR ('f'); + } + else + { + if (c == '\"' || c == '\\') + PRINTCHAR ('\\'); + PRINTCHAR (c); + } + } + PRINTCHAR ('\"'); + UNGCPRO; + } + else if (SUBRP (obj)) + { + strout ("#symbol_name, -1, printcharfun); + PRINTCHAR ('>'); + } #ifndef standalone - case Lisp_Buffer: - if (NILP (XBUFFER (obj)->name)) - strout ("#", -1, printcharfun); - else if (escapeflag) + else if (WINDOWP (obj)) { - strout ("#name, printcharfun); + strout ("#sequence_number)); + strout (buf, -1, printcharfun); + if (!NILP (XWINDOW (obj)->buffer)) + { + strout (" on ", -1, printcharfun); + print_string (XBUFFER (XWINDOW (obj)->buffer)->name, printcharfun); + } PRINTCHAR ('>'); } - else - print_string (XBUFFER (obj)->name, printcharfun); - break; - - case Lisp_Process: - if (escapeflag) + else if (BUFFERP (obj)) { - strout ("#name, printcharfun); + if (NILP (XBUFFER (obj)->name)) + strout ("#", -1, printcharfun); + else if (escapeflag) + { + strout ("#name, printcharfun); + PRINTCHAR ('>'); + } + else + print_string (XBUFFER (obj)->name, printcharfun); + } + else if (WINDOW_CONFIGURATIONP (obj)) + { + strout ("#", -1, printcharfun); + } + else if (FRAMEP (obj)) + { + strout ((FRAME_LIVE_P (XFRAME (obj)) + ? "#name, printcharfun); + sprintf (buf, " 0x%lx", (unsigned long) (XFRAME (obj))); + strout (buf, -1, printcharfun); PRINTCHAR ('>'); } +#endif /* not standalone */ else - print_string (XPROCESS (obj)->name, printcharfun); - break; - - case Lisp_Window: - strout ("#sequence_number)); - strout (buf, -1, printcharfun); - if (!NILP (XWINDOW (obj)->buffer)) { - strout (" on ", -1, printcharfun); - print_string (XBUFFER (XWINDOW (obj)->buffer)->name, printcharfun); - } - PRINTCHAR ('>'); - break; + int size = XVECTOR (obj)->size; + if (COMPILEDP (obj)) + { + PRINTCHAR ('#'); + size &= PSEUDOVECTOR_SIZE_MASK; + } + if (CHAR_TABLE_P (obj)) + { + /* We print a char-table as if it were a vector, + lumping the parent and default slots in with the + character slots. But we add #^ as a prefix. */ + PRINTCHAR ('#'); + PRINTCHAR ('^'); + if (SUB_CHAR_TABLE_P (obj)) + PRINTCHAR ('^'); + size &= PSEUDOVECTOR_SIZE_MASK; + } + if (size & PSEUDOVECTOR_FLAG) + goto badtype; - case Lisp_Window_Configuration: - strout ("#", -1, printcharfun); - break; + PRINTCHAR ('['); + { + register int i; + register Lisp_Object tem; -#ifdef MULTI_FRAME - case Lisp_Frame: - strout ((FRAME_LIVE_P (XFRAME (obj)) - ? "#name, printcharfun); - if (sizeof (EMACS_INT) > 4) - sprintf (buf, " 0x%lx", (EMACS_UINT) (XFRAME (obj))); - else - sprintf (buf, " 0x%x", (EMACS_UINT) (XFRAME (obj))); - strout (buf, -1, printcharfun); - strout (">", -1, printcharfun); + /* Don't print more elements than the specified maximum. */ + if (INTEGERP (Vprint_length) + && XINT (Vprint_length) < size) + size = XINT (Vprint_length); + + for (i = 0; i < size; i++) + { + if (i) PRINTCHAR (' '); + tem = XVECTOR (obj)->contents[i]; + print (tem, printcharfun, escapeflag); + } + } + PRINTCHAR (']'); + } break; -#endif /* MULTI_FRAME */ +#ifndef standalone case Lisp_Misc: - switch (XMISC (obj)->type) + switch (XMISCTYPE (obj)) { case Lisp_Misc_Marker: strout ("#insertion_type != 0) + strout ("(before-insertion) ", -1, printcharfun); +#endif /* 0 */ if (!(XMARKER (obj)->buffer)) strout ("in no buffer", -1, printcharfun); else @@ -1013,18 +1344,87 @@ print (obj, printcharfun, escapeflag) PRINTCHAR ('>'); break; + /* Remaining cases shouldn't happen in normal usage, but let's print + them anyway for the benefit of the debugger. */ + case Lisp_Misc_Free: + strout ("#", -1, printcharfun); + break; + + case Lisp_Misc_Intfwd: + sprintf (buf, "#", *XINTFWD (obj)->intvar); + strout (buf, -1, printcharfun); + break; + + case Lisp_Misc_Boolfwd: + sprintf (buf, "#", + (*XBOOLFWD (obj)->boolvar ? "t" : "nil")); + strout (buf, -1, printcharfun); + break; + + case Lisp_Misc_Objfwd: + strout ("#objvar, printcharfun, escapeflag); + PRINTCHAR ('>'); + break; + + case Lisp_Misc_Buffer_Objfwd: + strout ("#offset), + printcharfun, escapeflag); + PRINTCHAR ('>'); + break; + + case Lisp_Misc_Kboard_Objfwd: + strout ("#offset), + printcharfun, escapeflag); + PRINTCHAR ('>'); + break; + + case Lisp_Misc_Buffer_Local_Value: + strout ("#car, printcharfun, escapeflag); + strout ("[buffer] ", -1, printcharfun); + print (XCONS (XBUFFER_LOCAL_VALUE (obj)->cdr)->car, + printcharfun, escapeflag); + strout ("[alist-elt] ", -1, printcharfun); + print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj)->cdr)->cdr)->car, + printcharfun, escapeflag); + strout ("[default-value] ", -1, printcharfun); + print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj)->cdr)->cdr)->cdr, + printcharfun, escapeflag); + PRINTCHAR ('>'); + break; + default: - abort (); + goto badtype; } break; - #endif /* standalone */ - case Lisp_Subr: - strout ("#symbol_name, -1, printcharfun); - PRINTCHAR ('>'); - break; + default: + badtype: + { + /* We're in trouble if this happens! + Probably should just abort () */ + strout ("#size); + else + sprintf (buf, "(0x%02x)", (int) XTYPE (obj)); + strout (buf, -1, printcharfun); + strout (" Save your buffers immediately and please report this bug>", + -1, printcharfun); + } } print_depth--; @@ -1054,15 +1454,12 @@ print_interval (interval, printcharfun) void syms_of_print () { - staticpro (&Qprint_escape_newlines); - Qprint_escape_newlines = intern ("print-escape-newlines"); - DEFVAR_LISP ("standard-output", &Vstandard_output, "Output stream `print' uses by default for outputting a character.\n\ This may be any function of one argument.\n\ It may also be a buffer (output is inserted before point)\n\ or a marker (output is inserted and the marker is advanced)\n\ -or the symbol t (output appears in the minibuffer line)."); +or the symbol t (output appears in the echo area)."); Vstandard_output = Qt; Qstandard_output = intern ("standard-output"); staticpro (&Qstandard_output); @@ -1102,11 +1499,23 @@ A value of nil means no limit."); Also print formfeeds as backslash-f."); print_escape_newlines = 0; + DEFVAR_BOOL ("print-quoted", &print_quoted, + "Non-nil means print quoted forms with reader syntax.\n\ +I.e., (quote foo) prints as 'foo, (function foo) as #'foo, and, backquoted\n\ +forms print in the new syntax."); + print_quoted = 0; + + DEFVAR_BOOL ("print-gensym", &print_gensym, + "Non-nil means print uninterned symbols so they will read as uninterned.\n\ +I.e., the value of (make-symbol "foobar") prints as #:foobar."); + print_gensym = 0; + /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */ staticpro (&Vprin1_to_string_buffer); defsubr (&Sprin1); defsubr (&Sprin1_to_string); + defsubr (&Serror_message_string); defsubr (&Sprinc); defsubr (&Sprint); defsubr (&Sterpri); @@ -1116,6 +1525,12 @@ Also print formfeeds as backslash-f."); Qexternal_debugging_output = intern ("external-debugging-output"); staticpro (&Qexternal_debugging_output); + Qprint_escape_newlines = intern ("print-escape-newlines"); + staticpro (&Qprint_escape_newlines); + + staticpro (&printed_gensyms); + printed_gensyms = Qnil; + #ifndef standalone defsubr (&Swith_output_to_temp_buffer); #endif /* not standalone */