X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/bc9e300ca4735c9f85c3915fd735bd4a1ba63844..87850793c3c5351531e26a2f47797ddef82eb722:/src/print.c diff --git a/src/print.c b/src/print.c index 08663d10cd..be26917628 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,12 +15,12 @@ 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 @@ -30,6 +30,7 @@ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include "process.h" #include "dispextern.h" #include "termchar.h" +#include "keyboard.h" #endif /* not standalone */ #ifdef USE_TEXT_PROPERTIES @@ -293,15 +294,24 @@ strout (ptr, size, printcharfun) } /* 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)) + /* 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); + } else { /* Otherwise, fetch the string address for each character. */ @@ -316,10 +326,10 @@ 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; @@ -328,11 +338,11 @@ PRINTCHARFUN defaults to the value of `standard-output' (which see).") 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 @@ -387,6 +397,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 (); @@ -481,8 +492,8 @@ 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; @@ -496,9 +507,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 */ @@ -509,30 +520,38 @@ 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; + 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, @@ -540,8 +559,8 @@ 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; @@ -552,9 +571,9 @@ Output stream is PRINTCHARFUN, or value of standard-output (which see).") 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, @@ -562,8 +581,8 @@ 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; @@ -577,11 +596,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 @@ -589,7 +608,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 @@ -616,13 +635,89 @@ 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; + + 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 . * @@ -666,19 +761,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; @@ -753,7 +850,12 @@ print (obj, printcharfun, escapeflag) switch (XGCTYPE (obj)) { case Lisp_Int: - sprintf (buf, "%d", XINT (obj)); + if (sizeof (int) == sizeof (EMACS_INT)) + sprintf (buf, "%d", XINT (obj)); + else if (sizeof (long) == sizeof (EMACS_INT)) + sprintf (buf, "%ld", XINT (obj)); + else + abort (); strout (buf, -1, printcharfun); break; @@ -909,6 +1011,52 @@ print (obj, printcharfun, escapeflag) 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) / 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 ("#type) + switch (XMISCTYPE (obj)) { case Lisp_Misc_Marker: strout ("#'); break; - case Lisp_Misc_Display_Objfwd: - strout (buf, "#offset), - printcharfun, escapeflag); + case Lisp_Misc_Kboard_Objfwd: + strout (buf, "#offset), + printcharfun, escapeflag); PRINTCHAR ('>'); break; @@ -1093,7 +1253,7 @@ print (obj, printcharfun, escapeflag) Probably should just abort () */ strout ("#type); + sprintf (buf, "(MISC 0x%04x)", (int) XMISCTYPE (obj)); else if (VECTORLIKEP (obj)) sprintf (buf, "(PVEC 0x%08x)", (int) XVECTOR (obj)->size); else @@ -1139,7 +1299,7 @@ syms_of_print () 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); @@ -1184,6 +1344,7 @@ Also print formfeeds as backslash-f."); defsubr (&Sprin1); defsubr (&Sprin1_to_string); + defsubr (&Serror_message_string); defsubr (&Sprinc); defsubr (&Sprint); defsubr (&Sterpri);