X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/f7779190d4af7d175215683d56a1cc1096828ec9..1134b8547c41ce376bba631ddf644bf7d142e59b:/src/print.c diff --git a/src/print.c b/src/print.c index 62a679cc81..6760af3298 100644 --- a/src/print.c +++ b/src/print.c @@ -1,5 +1,5 @@ /* Lisp object printing and output streams. - Copyright (C) 1985, 86, 88, 93, 94, 95 Free Software Foundation, Inc. + Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -25,6 +25,7 @@ Boston, MA 02111-1307, USA. */ #ifndef standalone #include "buffer.h" +#include "charset.h" #include "frame.h" #include "window.h" #include "process.h" @@ -39,8 +40,59 @@ Boston, MA 02111-1307, 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; + +/* Work around a problem that happens because math.h on hpux 7 + defines two static variables--which, in Emacs, are not really static, + because `static' is defined as nothing. The problem is that they are + defined both here and in lread.c. + These macros prevent the name conflict. */ +#if defined (HPUX) && !defined (HPUX8) +#define _MAXLDBL print_maxldbl +#define _NMAXLDBL print_nmaxldbl +#endif + +#include + +#if STDC_HEADERS +#include +#include +#endif + +/* Default to values appropriate for IEEE floating point. */ +#ifndef FLT_RADIX +#define FLT_RADIX 2 +#endif +#ifndef DBL_MANT_DIG +#define DBL_MANT_DIG 53 +#endif +#ifndef DBL_DIG +#define DBL_DIG 15 +#endif +#ifndef DBL_MIN +#define DBL_MIN 2.2250738585072014e-308 +#endif + +#ifdef DBL_MIN_REPLACEMENT +#undef DBL_MIN +#define DBL_MIN DBL_MIN_REPLACEMENT +#endif + +/* Define DOUBLE_DIGITS_BOUND, an upper bound on the number of decimal digits + needed to express a float without losing information. + The general-case formula is valid for the usual case, IEEE floating point, + but many compilers can't optimize the formula to an integer constant, + so make a special case for it. */ +#if FLT_RADIX == 2 && DBL_MANT_DIG == 53 +#define DOUBLE_DIGITS_BOUND 17 /* IEEE floating point */ +#else +#define DOUBLE_DIGITS_BOUND ((int) ceil (log10 (pow (FLT_RADIX, DBL_MANT_DIG)))) +#endif + #endif /* LISP_FLOAT_TYPE */ /* Avoid actual stack overflow in print. */ @@ -50,6 +102,17 @@ 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; +/* Chars stored in print_buffer. */ +int print_buffer_pos; +/* Bytes stored in print_buffer. */ +int print_buffer_pos_byte; + /* Maximum length of list to print in full; noninteger means effectively infinity */ @@ -66,11 +129,29 @@ int print_escape_newlines; Lisp_Object Qprint_escape_newlines; +/* Nonzero means print (quote foo) forms as 'foo, etc. */ + +int print_quoted; + +/* Non-nil means print #: before uninterned symbols. + Neither t nor nil means so that and don't clear Vprint_gensym_alist + on entry to and exit from print functions. */ + +Lisp_Object Vprint_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 Vprint_gensym_alist; + /* Nonzero means print newline to stdout before next minibuffer message. Defined in xdisp.c */ extern int noninteractive_need_newline; +extern int minibuffer_auto_raise; + #ifdef MAX_PRINT_CHARS static int print_chars; static int max_print; @@ -133,50 +214,112 @@ 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 old_point_byte, start_point_byte; \ + 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; \ - SET_PT (marker_position (printcharfun)); \ - start_point = point; \ - printcharfun = Qnil;} + old_point = PT; \ + old_point_byte = PT_BYTE; \ + SET_PT_BOTH (marker_position (printcharfun), \ + marker_byte_position (printcharfun)); \ + start_point = PT; \ + start_point_byte = PT_BYTE; \ + printcharfun = Qnil; \ + } \ + if (NILP (printcharfun)) \ + { \ + Lisp_Object string; \ + if (print_buffer != 0) \ + { \ + string = make_multibyte_string (print_buffer, \ + print_buffer_pos, \ + print_buffer_pos_byte); \ + record_unwind_protect (print_unwind, string); \ + } \ + else \ + { \ + print_buffer_size = 1000; \ + print_buffer = (char *) xmalloc (print_buffer_size); \ + free_print_buffer = 1; \ + } \ + print_buffer_pos = 0; \ + print_buffer_pos_byte = 0; \ + } \ + if (!CONSP (Vprint_gensym)) \ + Vprint_gensym_alist = Qnil #define PRINTFINISH \ + if (NILP (printcharfun)) \ + insert_1_both (print_buffer, print_buffer_pos, \ + print_buffer_pos_byte, 0, 1, 0); \ + 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); \ + set_marker_both (original, Qnil, PT, PT_BYTE); \ if (old_point >= 0) \ - SET_PT (old_point + (old_point >= start_point \ - ? point - start_point : 0)); \ + SET_PT_BOTH (old_point + (old_point >= start_point \ + ? PT - start_point : 0), \ + old_point_byte + (old_point_byte >= start_point_byte \ + ? PT_BYTE - start_point_byte : 0)); \ if (old != current_buffer) \ - set_buffer_internal (old) + set_buffer_internal (old); \ + if (!CONSP (Vprint_gensym)) \ + Vprint_gensym_alist = 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; @@ -188,8 +331,17 @@ printchar (ch, fun) #ifndef standalone if (EQ (fun, Qnil)) { + int len; + unsigned char work[4], *str; + QUIT; - insert (&ch, 1); + len = CHAR_STRING (ch, work, str); + if (print_buffer_pos_byte + len >= print_buffer_size) + print_buffer = (char *) xrealloc (print_buffer, + print_buffer_size *= 2); + bcopy (str, print_buffer + print_buffer_pos_byte, len); + print_buffer_pos += 1; + print_buffer_pos_byte += len; return; } @@ -197,10 +349,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; } @@ -213,11 +370,42 @@ printchar (ch, fun) printbufidx = 0; echo_area_glyphs_length = 0; message_buf_print = 1; + + if (minibuffer_auto_raise) + { + Lisp_Object mini_window; + + /* Get the frame containing the minibuffer + that the selected frame is using. */ + mini_window = FRAME_MINIBUF_WINDOW (selected_frame); + + Fraise_frame (WINDOW_FRAME (XWINDOW (mini_window))); + } } - message_dolog (&ch, 1, 0); - if (printbufidx < FRAME_WIDTH (mini_frame) - 1) - FRAME_MESSAGE_BUF (mini_frame)[printbufidx++] = ch; + message_dolog (str, len, 0, len > 1); + + /* Convert message to multibyte if we are now adding multibyte text. */ + if (! NILP (current_buffer->enable_multibyte_characters) + && ! message_enable_multibyte + && printbufidx > 0) + { + int size = count_size_as_multibyte (FRAME_MESSAGE_BUF (mini_frame), + printbufidx); + unsigned char *tembuf = (unsigned char *) alloca (size + 1); + copy_text (FRAME_MESSAGE_BUF (mini_frame), tembuf, printbufidx, + 0, 1); + printbufidx = size; + if (printbufidx > FRAME_MESSAGE_BUF_SIZE (mini_frame)) + printbufidx = FRAME_MESSAGE_BUF_SIZE (mini_frame); + bcopy (tembuf, FRAME_MESSAGE_BUF (mini_frame), printbufidx); + } + message_enable_multibyte + = ! NILP (current_buffer->enable_multibyte_characters); + + 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; @@ -230,19 +418,32 @@ printchar (ch, fun) } static void -strout (ptr, size, printcharfun) +strout (ptr, size, size_byte, printcharfun, multibyte) char *ptr; - int size; + int size, size_byte; Lisp_Object printcharfun; + int multibyte; { int i = 0; + if (size < 0) + size_byte = size = strlen (ptr); + if (EQ (printcharfun, Qnil)) { - insert (ptr, size >= 0 ? size : strlen (ptr)); + if (print_buffer_pos_byte + size_byte > print_buffer_size) + { + print_buffer_size = print_buffer_size * 2 + size_byte; + print_buffer = (char *) xrealloc (print_buffer, + print_buffer_size); + } + bcopy (ptr, print_buffer + print_buffer_pos_byte, size_byte); + print_buffer_pos += size; + print_buffer_pos_byte += size_byte; + #ifdef MAX_PRINT_CHARS if (max_print) - print_chars += size >= 0 ? size : strlen(ptr); + print_chars += size; #endif /* MAX_PRINT_CHARS */ return; } @@ -251,15 +452,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_byte, stdout); noninteractive_need_newline = 1; return; } @@ -272,55 +474,94 @@ strout (ptr, size, printcharfun) printbufidx = 0; echo_area_glyphs_length = 0; message_buf_print = 1; + + if (minibuffer_auto_raise) + { + Lisp_Object mini_window; + + /* Get the frame containing the minibuffer + that the selected frame is using. */ + mini_window = FRAME_MINIBUF_WINDOW (selected_frame); + + Fraise_frame (WINDOW_FRAME (XWINDOW (mini_window))); + } } - message_dolog (ptr, i, 0); - 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_byte, 0, multibyte); + if (size_byte > FRAME_MESSAGE_BUF_SIZE (mini_frame) - printbufidx - 1) + { + size_byte = FRAME_MESSAGE_BUF_SIZE (mini_frame) - printbufidx - 1; + /* Rewind incomplete multi-byte form. */ + while (size_byte && (unsigned char) ptr[size] >= 0xA0) size--; + } + bcopy (ptr, &FRAME_MESSAGE_BUF (mini_frame) [printbufidx], size_byte); + printbufidx += size_byte; echo_area_glyphs_length = printbufidx; FRAME_MESSAGE_BUF (mini_frame) [printbufidx] = 0; return; } - if (size >= 0) - while (i < size) - PRINTCHAR (ptr[i++]); + i = 0; + if (size == size_byte) + while (i < size_byte) + { + int ch = ptr[i++]; + + PRINTCHAR (ch); + } else - while (ptr[i]) - PRINTCHAR (ptr[i++]); + while (i < size_byte) + { + /* 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_byte - i, len); + + PRINTCHAR (ch); + i += len; + } } /* Print the contents of a string STRING using PRINTCHARFUN. It isn't safe to use strout in many cases, because printing one char can relocate. */ +static void print_string (string, printcharfun) Lisp_Object string; Lisp_Object printcharfun; { - if (EQ (printcharfun, Qt)) - /* strout is safe for output to a frame (echo area). */ - strout (XSTRING (string)->data, XSTRING (string)->size, printcharfun); - else if (EQ (printcharfun, Qnil)) - { -#ifdef MAX_PRINT_CHARS - if (max_print) - print_chars += XSTRING (string)->size; -#endif /* MAX_PRINT_CHARS */ - insert_from_string (string, 0, XSTRING (string)->size, 1); - } + 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, + XSTRING (string)->size_byte, + printcharfun, STRING_MULTIBYTE (string)); else { - /* Otherwise, fetch the string address for each character. */ + /* Otherwise, string may be relocated by printing one char. + So re-fetch the string address for each character. */ int i; int size = XSTRING (string)->size; + int size_byte = XSTRING (string)->size_byte; struct gcpro gcpro1; GCPRO1 (string); - for (i = 0; i < size; i++) - PRINTCHAR (XSTRING (string)->data[i]); + if (size == size_byte) + for (i = 0; i < size; i++) + PRINTCHAR (XSTRING (string)->data[i]); + else + for (i = 0; i < size_byte; i++) + { + /* 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 (XSTRING (string)->data + i, + size_byte - i, len); + + PRINTCHAR (ch); + i += len; + } UNGCPRO; } } @@ -331,10 +572,7 @@ PRINTCHARFUN defaults to the value of `standard-output' (which see).") (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; @@ -345,43 +583,39 @@ PRINTCHARFUN defaults to the value of `standard-output' (which see).") return character; } -/* Used from outside of print.c to print a block of SIZE chars at DATA - on the default output stream. +/* Used from outside of print.c to print a block of SIZE + single-byte chars at DATA on the default output stream. Do not use this on the contents of a Lisp string. */ +void 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; PRINTPREPARE; - strout (data, size, printcharfun); + strout (data, size, size, printcharfun, 0); PRINTFINISH; } -/* Used from outside of print.c to print a block of SIZE chars at DATA - on a specified stream PRINTCHARFUN. +/* Used from outside of print.c to print a block of SIZE + single-byte chars at DATA on a specified stream PRINTCHARFUN. Do not use this on the contents of a Lisp string. */ +void write_string_1 (data, size, printcharfun) char *data; 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); + strout (data, size, size, printcharfun, 0); PRINTFINISH; } @@ -474,10 +708,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; @@ -495,10 +726,7 @@ Output stream is PRINTCHARFUN, or value of `standard-output' (which see).") (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; @@ -523,10 +751,8 @@ second argument NOESCAPE is non-nil.") (object, noescape) Lisp_Object object, noescape; { - struct buffer *old = current_buffer; - int old_point = -1; - int start_point; - Lisp_Object original, printcharfun; + PRINTDECLARE; + Lisp_Object printcharfun; struct gcpro gcpro1, gcpro2; Lisp_Object tem; @@ -562,10 +788,7 @@ Output stream is PRINTCHARFUN, or value of standard-output (which see).") (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; @@ -584,10 +807,7 @@ Output stream is PRINTCHARFUN, or value of `standard-output' (which see).") (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 @@ -624,7 +844,15 @@ to make it write to the debugging output.\n") { CHECK_NUMBER (character, 0); putc (XINT (character), stderr); - + +#ifdef WINDOWSNT + /* Send the output to a debugger (nothing happens if there isn't one). */ + { + char buf[2] = {(char) XINT (character), '\0'}; + OutputDebugString (buf); + } +#endif + return character; } @@ -648,7 +876,16 @@ DEFUN ("error-message-string", Ferror_message_string, Serror_message_string, Lisp_Object original, printcharfun, value; struct gcpro gcpro1; - print_error_message (obj, Vprin1_to_string_buffer, NULL); + /* 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); set_buffer_internal (XBUFFER (Vprin1_to_string_buffer)); value = Fbuffer_string (); @@ -664,6 +901,7 @@ DEFUN ("error-message-string", Ferror_message_string, Serror_message_string, /* Print an error message for the error DATA onto Lisp output stream STREAM (suitable for the print functions). */ +void print_error_message (data, stream) Lisp_Object data, stream; { @@ -737,12 +975,45 @@ float_to_string (buf, data) unsigned char *cp; int width; + /* Check for plus infinity in a way that won't lose + if there is no plus infinity. */ + if (data == data / 2 && data > 1.0) + { + strcpy (buf, "1.0e+INF"); + return; + } + /* Likewise for minus infinity. */ + if (data == data / 2 && data < -1.0) + { + strcpy (buf, "-1.0e+INF"); + return; + } + /* Check for NaN in a way that won't fail if there are no NaNs. */ + if (! (data * 0.0 >= 0.0)) + { + strcpy (buf, "0.0e+NaN"); + return; + } + if (NILP (Vfloat_output_format) || !STRINGP (Vfloat_output_format)) lose: { - sprintf (buf, "%.17g", data); - width = -1; + /* Generate the fewest number of digits that represent the + floating point value without losing information. + The following method is simple but a bit slow. + For ideas about speeding things up, please see: + + Guy L Steele Jr & Jon L White, How to print floating-point numbers + accurately. SIGPLAN notices 25, 6 (June 1990), 112-126. + + Robert G Burger & R Kent Dybvig, Printing floating point numbers + quickly and accurately, SIGPLAN notices 31, 5 (May 1996), 108-116. */ + + width = fabs (data) < DBL_MIN ? 1 : DBL_DIG; + do + sprintf (buf, "%.*g", width, data); + while (width++ < DOUBLE_DIGITS_BOUND && atof (buf) != data); } else /* oink oink */ { @@ -828,7 +1099,7 @@ print (obj, printcharfun, escapeflag) if (EQ (obj, being_printed[i])) { sprintf (buf, "#%d", i); - strout (buf, -1, printcharfun); + strout (buf, -1, -1, printcharfun, 0); return; } } @@ -856,7 +1127,7 @@ print (obj, printcharfun, escapeflag) sprintf (buf, "%ld", XINT (obj)); else abort (); - strout (buf, -1, printcharfun); + strout (buf, -1, -1, printcharfun, 0); break; #ifdef LISP_FLOAT_TYPE @@ -865,7 +1136,7 @@ print (obj, printcharfun, escapeflag) char pigbuf[350]; /* see comments in float_to_string */ float_to_string (pigbuf, XFLOAT(obj)->data); - strout (pigbuf, -1, printcharfun); + strout (pigbuf, -1, -1, printcharfun, 0); } break; #endif @@ -875,9 +1146,10 @@ print (obj, printcharfun, escapeflag) print_string (obj, printcharfun); else { - register int i; + register int i, i_byte; register unsigned char c; struct gcpro gcpro1; + int size_byte; GCPRO1 (obj); @@ -890,10 +1162,22 @@ print (obj, printcharfun, escapeflag) #endif PRINTCHAR ('\"'); - for (i = 0; i < XSTRING (obj)->size; i++) + size_byte = XSTRING (obj)->size_byte; + + for (i = 0, i_byte = 0; i_byte < size_byte;) { + /* Here, we must convert each multi-byte form to the + corresponding character code before handing it to PRINTCHAR. */ + int len; + int c; + + if (STRING_MULTIBYTE (obj)) + FETCH_STRING_CHAR_ADVANCE (c, obj, i, i_byte); + else + c = XSTRING (obj)->data[i_byte++]; + QUIT; - c = XSTRING (obj)->data[i]; + if (c == '\n' && print_escape_newlines) { PRINTCHAR ('\\'); @@ -904,6 +1188,26 @@ print (obj, printcharfun, escapeflag) PRINTCHAR ('\\'); PRINTCHAR ('f'); } + else if ((! SINGLE_BYTE_CHAR_P (c) + && NILP (current_buffer->enable_multibyte_characters))) + { + /* When multibyte is disabled, + print multibyte string chars using hex escapes. */ + unsigned char outbuf[50]; + sprintf (outbuf, "\\x%x", c); + strout (outbuf, -1, -1, printcharfun, 0); + } + else if (SINGLE_BYTE_CHAR_P (c) + && ! ASCII_BYTE_P (c) + && ! NILP (current_buffer->enable_multibyte_characters)) + { + /* When multibyte is enabled, + print single-byte non-ASCII string chars + using octal escapes. */ + unsigned char outbuf[5]; + sprintf (outbuf, "\\%03o", c); + strout (outbuf, -1, -1, printcharfun, 0); + } else { if (c == '\"' || c == '\\') @@ -930,29 +1234,89 @@ print (obj, printcharfun, escapeflag) { register int confusing; register unsigned char *p = XSYMBOL (obj)->name->data; - register unsigned char *end = p + XSYMBOL (obj)->name->size; - register unsigned char c; + register unsigned char *end = p + XSYMBOL (obj)->name->size_byte; + register int c; + int i, i_byte, size_byte; + Lisp_Object name; + + XSETSTRING (name, XSYMBOL (obj)->name); if (p != end && (*p == '-' || *p == '+')) p++; 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; + + /* 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 (! NILP (Vprint_gensym) && NILP (XSYMBOL (obj)->obarray)) + { + if (print_depth > 1) + { + Lisp_Object tem; + tem = Fassq (obj, Vprint_gensym_alist); + if (CONSP (tem)) + { + PRINTCHAR ('#'); + print (XCDR (tem), printcharfun, escapeflag); + PRINTCHAR ('#'); + break; + } + else + { + if (CONSP (Vprint_gensym_alist)) + XSETFASTINT (tem, XFASTINT (XCDR (XCAR (Vprint_gensym_alist))) + 1); + else + XSETFASTINT (tem, 1); + Vprint_gensym_alist = Fcons (Fcons (obj, tem), Vprint_gensym_alist); + + PRINTCHAR ('#'); + print (tem, printcharfun, escapeflag); + PRINTCHAR ('='); + } + } + PRINTCHAR ('#'); + PRINTCHAR (':'); + } + + size_byte = XSTRING (name)->size_byte; - p = XSYMBOL (obj)->name->data; - while (p != end) + for (i = 0, i_byte = 0; i_byte < size_byte;) { + /* Here, we must convert each multi-byte form to the + corresponding character code before handing it to PRINTCHAR. */ + + if (STRING_MULTIBYTE (name)) + FETCH_STRING_CHAR_ADVANCE (c, name, i, i_byte); + else + c = XSTRING (name)->data[i_byte++]; + QUIT; - c = *p++; + 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); @@ -964,7 +1328,29 @@ print (obj, printcharfun, escapeflag) /* If deeper than spec'd depth, print placeholder. */ if (INTEGERP (Vprint_level) && print_depth > XINT (Vprint_level)) - strout ("...", -1, printcharfun); + strout ("...", -1, -1, printcharfun, 0); + else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj))) + && (EQ (XCAR (obj), Qquote))) + { + PRINTCHAR ('\''); + print (XCAR (XCDR (obj)), printcharfun, escapeflag); + } + 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 ('('); @@ -983,16 +1369,16 @@ print (obj, printcharfun, escapeflag) PRINTCHAR (' '); if (max && i > max) { - strout ("...", 3, printcharfun); + strout ("...", 3, 3, printcharfun, 0); break; } - print (Fcar (obj), printcharfun, escapeflag); - obj = Fcdr (obj); + print (XCAR (obj), printcharfun, escapeflag); + obj = XCDR (obj); } } - if (!NILP (obj) && !CONSP (obj)) + if (!NILP (obj)) { - strout (" . ", 3, printcharfun); + strout (" . ", 3, 3, printcharfun, 0); print (obj, printcharfun, escapeflag); } PRINTCHAR (')'); @@ -1004,7 +1390,7 @@ print (obj, printcharfun, escapeflag) { if (escapeflag) { - strout ("#name, printcharfun); PRINTCHAR ('>'); } @@ -1017,14 +1403,14 @@ print (obj, printcharfun, escapeflag) register unsigned char c; struct gcpro gcpro1; int size_in_chars - = (XBOOL_VECTOR (obj)->size + BITS_PER_CHAR) / BITS_PER_CHAR; + = (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); + strout (buf, -1, -1, printcharfun, 0); PRINTCHAR ('\"'); /* Don't print more characters than the specified maximum. */ @@ -1059,19 +1445,19 @@ print (obj, printcharfun, escapeflag) } else if (SUBRP (obj)) { - strout ("#symbol_name, -1, printcharfun); + strout ("#symbol_name, -1, -1, printcharfun, 0); PRINTCHAR ('>'); } #ifndef standalone else if (WINDOWP (obj)) { - strout ("#sequence_number)); - strout (buf, -1, printcharfun); + strout (buf, -1, -1, printcharfun, 0); if (!NILP (XWINDOW (obj)->buffer)) { - strout (" on ", -1, printcharfun); + strout (" on ", -1, -1, printcharfun, 0); print_string (XBUFFER (XWINDOW (obj)->buffer)->name, printcharfun); } PRINTCHAR ('>'); @@ -1079,10 +1465,10 @@ print (obj, printcharfun, escapeflag) else if (BUFFERP (obj)) { if (NILP (XBUFFER (obj)->name)) - strout ("#", -1, printcharfun); + strout ("#", -1, -1, printcharfun, 0); else if (escapeflag) { - strout ("#name, printcharfun); PRINTCHAR ('>'); } @@ -1091,20 +1477,18 @@ print (obj, printcharfun, escapeflag) } else if (WINDOW_CONFIGURATIONP (obj)) { - strout ("#", -1, printcharfun); + strout ("#", -1, -1, printcharfun, 0); } -#ifdef MULTI_FRAME else if (FRAMEP (obj)) { strout ((FRAME_LIVE_P (XFRAME (obj)) ? "#name, printcharfun); - sprintf (buf, " 0x%lx", (unsigned long) (XFRAME (obj))); - strout (buf, -1, printcharfun); + sprintf (buf, " 0x%lx\\ ", (unsigned long) (XFRAME (obj))); + strout (buf, -1, -1, printcharfun, 0); PRINTCHAR ('>'); } -#endif #endif /* not standalone */ else { @@ -1121,6 +1505,8 @@ print (obj, printcharfun, escapeflag) 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) @@ -1152,29 +1538,32 @@ print (obj, printcharfun, escapeflag) switch (XMISCTYPE (obj)) { case Lisp_Misc_Marker: - strout ("#insertion_type != 0) + strout ("(before-insertion) ", -1, -1, printcharfun, 0); if (!(XMARKER (obj)->buffer)) - strout ("in no buffer", -1, printcharfun); + strout ("in no buffer", -1, -1, printcharfun, 0); else { sprintf (buf, "at %d", marker_position (obj)); - strout (buf, -1, printcharfun); - strout (" in ", -1, printcharfun); + strout (buf, -1, -1, printcharfun, 0); + strout (" in ", -1, -1, printcharfun, 0); print_string (XMARKER (obj)->buffer->name, printcharfun); } PRINTCHAR ('>'); break; case Lisp_Misc_Overlay: - strout ("#buffer)) - strout ("in no buffer", -1, printcharfun); + strout ("in no buffer", -1, -1, printcharfun, 0); else { sprintf (buf, "from %d to %d in ", marker_position (OVERLAY_START (obj)), marker_position (OVERLAY_END (obj))); - strout (buf, -1, printcharfun); + strout (buf, -1, -1, printcharfun, 0); print_string (XMARKER (OVERLAY_START (obj))->buffer->name, printcharfun); } @@ -1184,28 +1573,28 @@ print (obj, printcharfun, escapeflag) /* 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); + strout ("#", -1, -1, printcharfun, 0); break; case Lisp_Misc_Intfwd: sprintf (buf, "#", *XINTFWD (obj)->intvar); - strout (buf, -1, printcharfun); + strout (buf, -1, -1, printcharfun, 0); break; case Lisp_Misc_Boolfwd: sprintf (buf, "#", (*XBOOLFWD (obj)->boolvar ? "t" : "nil")); - strout (buf, -1, printcharfun); + strout (buf, -1, -1, printcharfun, 0); break; case Lisp_Misc_Objfwd: - strout ("#objvar, printcharfun, escapeflag); PRINTCHAR ('>'); break; case Lisp_Misc_Buffer_Objfwd: - strout ("#offset), printcharfun, escapeflag); @@ -1213,7 +1602,7 @@ print (obj, printcharfun, escapeflag) break; case Lisp_Misc_Kboard_Objfwd: - strout ("#offset), printcharfun, escapeflag); @@ -1221,20 +1610,20 @@ print (obj, printcharfun, escapeflag) break; case Lisp_Misc_Buffer_Local_Value: - strout ("#car, printcharfun, escapeflag); - strout ("[buffer] ", -1, printcharfun); + strout ("[buffer] ", -1, -1, printcharfun, 0); print (XCONS (XBUFFER_LOCAL_VALUE (obj)->cdr)->car, printcharfun, escapeflag); - strout ("[alist-elt] ", -1, printcharfun); + strout ("[alist-elt] ", -1, -1, printcharfun, 0); print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj)->cdr)->cdr)->car, printcharfun, escapeflag); - strout ("[default-value] ", -1, printcharfun); + strout ("[default-value] ", -1, -1, printcharfun, 0); print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj)->cdr)->cdr)->cdr, printcharfun, escapeflag); PRINTCHAR ('>'); @@ -1251,16 +1640,16 @@ print (obj, printcharfun, escapeflag) { /* 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 (buf, -1, -1, printcharfun, 0); strout (" Save your buffers immediately and please report this bug>", - -1, printcharfun); + -1, -1, printcharfun, 0); } } @@ -1291,9 +1680,6 @@ 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\ @@ -1318,7 +1704,8 @@ Use `g' to choose the shorter of those two formats for the number at hand.\n\ The precision in any of these cases is the number of digits following\n\ the decimal point. With `f', a precision of 0 means to omit the\n\ decimal point. 0 is not allowed with `e' or `g'.\n\n\ -A value of nil means to use `%.17g'."); +A value of nil means to use the shortest notation\n\ +that represents the number without losing information."); Vfloat_output_format = Qnil; Qfloat_output_format = intern ("float-output-format"); staticpro (&Qfloat_output_format); @@ -1339,6 +1726,32 @@ 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_LISP ("print-gensym", &Vprint_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.\n\ +When the uninterned symbol appears within a larger data structure,\n\ +in addition use the #...# and #...= constructs as needed,\n\ +so that multiple references to the same symbol are shared once again\n\ +when the text is read back.\n\ +\n\ +If the value of `print-gensym' is a cons cell, then in addition refrain from\n\ +clearing `print-gensym-alist' on entry to and exit from printing functions,\n\ +so that the use of #...# and #...= can carry over for several separately\n\ +printed objects."); + Vprint_gensym = Qnil; + + DEFVAR_LISP ("print-gensym-alist", &Vprint_gensym_alist, + "Association list of elements (GENSYM . N) to guide use of #N# and #N=.\n\ +In each element, GENSYM is an uninterned symbol that has been associated\n\ +with #N= for the specified value of N."); + Vprint_gensym_alist = Qnil; + /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */ staticpro (&Vprin1_to_string_buffer); @@ -1354,6 +1767,9 @@ 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); + #ifndef standalone defsubr (&Swith_output_to_temp_buffer); #endif /* not standalone */