X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/0f668a4db4a33f98f84613513af3efea521b4847..9f62b5dd0e873f6048630e1e59a371112bdcf720:/src/print.c diff --git a/src/print.c b/src/print.c index e87bbcce0e..6ed0f51cbe 100644 --- a/src/print.c +++ b/src/print.c @@ -1,6 +1,6 @@ /* Lisp object printing and output streams. -Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2013 Free Software +Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2014 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -20,7 +20,7 @@ along with GNU Emacs. If not, see . */ #include -#include +#include "sysstdio.h" #include "lisp.h" #include "character.h" @@ -84,7 +84,7 @@ static ptrdiff_t print_number_index; static void print_interval (INTERVAL interval, Lisp_Object printcharfun); /* GDB resets this to zero on W32 to disable OutputDebugString calls. */ -int print_output_debug_flag EXTERNALLY_VISIBLE = 1; +bool print_output_debug_flag EXTERNALLY_VISIBLE = 1; /* Low level output routines for characters and strings. */ @@ -100,9 +100,10 @@ int print_output_debug_flag EXTERNALLY_VISIBLE = 1; struct buffer *old = current_buffer; \ ptrdiff_t old_point = -1, start_point = -1; \ ptrdiff_t old_point_byte = -1, start_point_byte = -1; \ - ptrdiff_t specpdl_count = SPECPDL_INDEX (); \ - int free_print_buffer = 0; \ - int multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters)); \ + dynwind_begin (); \ + bool free_print_buffer = 0; \ + bool multibyte \ + = !NILP (BVAR (current_buffer, enable_multibyte_characters)); \ Lisp_Object original #define PRINTPREPARE \ @@ -123,7 +124,8 @@ int print_output_debug_flag EXTERNALLY_VISIBLE = 1; set_buffer_internal (XMARKER (printcharfun)->buffer); \ marker_pos = marker_position (printcharfun); \ if (marker_pos < BEGV || marker_pos > ZV) \ - error ("Marker is outside the accessible part of the buffer"); \ + signal_error ("Marker is outside the accessible " \ + "part of the buffer", printcharfun); \ old_point = PT; \ old_point_byte = PT_BYTE; \ SET_PT_BOTH (marker_pos, \ @@ -135,10 +137,10 @@ int print_output_debug_flag EXTERNALLY_VISIBLE = 1; if (NILP (printcharfun)) \ { \ Lisp_Object string; \ - if (NILP (BVAR (current_buffer, enable_multibyte_characters)) \ + if (NILP (BVAR (current_buffer, enable_multibyte_characters)) \ && ! print_escape_multibyte) \ specbind (Qprint_escape_multibyte, Qt); \ - if (! NILP (BVAR (current_buffer, enable_multibyte_characters)) \ + if (! NILP (BVAR (current_buffer, enable_multibyte_characters)) \ && ! print_escape_nonascii) \ specbind (Qprint_escape_nonascii, Qt); \ if (print_buffer != 0) \ @@ -151,7 +153,7 @@ int print_output_debug_flag EXTERNALLY_VISIBLE = 1; else \ { \ int new_size = 1000; \ - print_buffer = xmalloc (new_size); \ + print_buffer = xmalloc_atomic (new_size); \ print_buffer_size = new_size; \ free_print_buffer = 1; \ } \ @@ -165,7 +167,7 @@ int print_output_debug_flag EXTERNALLY_VISIBLE = 1; if (NILP (printcharfun)) \ { \ if (print_buffer_pos != print_buffer_pos_byte \ - && NILP (BVAR (current_buffer, enable_multibyte_characters))) \ + && NILP (BVAR (current_buffer, enable_multibyte_characters)))\ { \ unsigned char *temp = alloca (print_buffer_pos + 1); \ copy_text ((unsigned char *) print_buffer, temp, \ @@ -183,7 +185,7 @@ int print_output_debug_flag EXTERNALLY_VISIBLE = 1; xfree (print_buffer); \ print_buffer = 0; \ } \ - unbind_to (specpdl_count, Qnil); \ + dynwind_end (); \ if (MARKERP (original)) \ set_marker_both (original, Qnil, PT, PT_BYTE); \ if (old_point >= 0) \ @@ -198,11 +200,10 @@ int print_output_debug_flag EXTERNALLY_VISIBLE = 1; /* This is used to restore the saved contents of print_buffer when there is a recursive call to print. */ -static Lisp_Object +static void print_unwind (Lisp_Object saved_text) { memcpy (print_buffer, SDATA (saved_text), SCHARS (saved_text)); - return Qnil; } @@ -226,9 +227,9 @@ printchar (unsigned int ch, Lisp_Object fun) if (NILP (fun)) { ptrdiff_t incr = len - (print_buffer_size - print_buffer_pos_byte); - if (0 < incr) - print_buffer = - xpalloc (print_buffer, &print_buffer_size, incr, -1, 1); + if (incr > 0) + print_buffer = xpalloc (print_buffer, &print_buffer_size, + incr, -1, 1); memcpy (print_buffer + print_buffer_pos_byte, str, len); print_buffer_pos += 1; print_buffer_pos_byte += len; @@ -240,7 +241,7 @@ printchar (unsigned int ch, Lisp_Object fun) } else { - int multibyte_p + bool multibyte_p = !NILP (BVAR (current_buffer, enable_multibyte_characters)); setup_echo_area_for_printing (multibyte_p); @@ -272,7 +273,7 @@ strout (const char *ptr, ptrdiff_t size, ptrdiff_t size_byte, if (NILP (printcharfun)) { ptrdiff_t incr = size_byte - (print_buffer_size - print_buffer_pos_byte); - if (0 < incr) + if (incr > 0) print_buffer = xpalloc (print_buffer, &print_buffer_size, incr, -1, 1); memcpy (print_buffer + print_buffer_pos_byte, ptr, size_byte); print_buffer_pos += size; @@ -289,7 +290,7 @@ strout (const char *ptr, ptrdiff_t size, ptrdiff_t size_byte, here, that's the reason we don't call printchar to do the job. */ int i; - int multibyte_p + bool multibyte_p = !NILP (BVAR (current_buffer, enable_multibyte_characters)); setup_echo_area_for_printing (multibyte_p); @@ -477,10 +478,10 @@ write_string_1 (const char *data, int size, Lisp_Object printcharfun) void temp_output_buffer_setup (const char *bufname) { - ptrdiff_t count = SPECPDL_INDEX (); register struct buffer *old = current_buffer; register Lisp_Object buf; + dynwind_begin (); record_unwind_current_buffer (); Fset_buffer (Fget_buffer_create (build_string (bufname))); @@ -502,15 +503,15 @@ temp_output_buffer_setup (const char *bufname) Frun_hooks (1, &Qtemp_buffer_setup_hook); - unbind_to (count, Qnil); + dynwind_end (); specbind (Qstandard_output, buf); } -static void print (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag); -static void print_preprocess (Lisp_Object obj); -static void print_preprocess_string (INTERVAL interval, Lisp_Object arg); -static void print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag); +static void print (Lisp_Object, Lisp_Object, bool); +static void print_preprocess (Lisp_Object); +static void print_preprocess_string (INTERVAL, Lisp_Object); +static void print_object (Lisp_Object, Lisp_Object, bool); DEFUN ("terpri", Fterpri, Sterpri, 0, 1, 0, doc: /* Output a newline to stream PRINTCHARFUN. @@ -582,9 +583,9 @@ A printed representation of an object is text which describes that object. */) bool prev_abort_on_gc; /* struct gcpro gcpro1, gcpro2; */ Lisp_Object save_deactivate_mark; - ptrdiff_t count = SPECPDL_INDEX (); struct buffer *previous; + dynwind_begin (); specbind (Qinhibit_modification_hooks, Qt); { @@ -595,8 +596,6 @@ A printed representation of an object is text which describes that object. */) No need for specbind, since errors deactivate the mark. */ save_deactivate_mark = Vdeactivate_mark; /* GCPRO2 (object, save_deactivate_mark); */ - prev_abort_on_gc = abort_on_gc; - abort_on_gc = 1; printcharfun = Vprin1_to_string_buffer; PRINTPREPARE; @@ -620,8 +619,8 @@ A printed representation of an object is text which describes that object. */) Vdeactivate_mark = save_deactivate_mark; /* UNGCPRO; */ - abort_on_gc = prev_abort_on_gc; - return unbind_to (count, object); + dynwind_end (); + return object; } DEFUN ("princ", Fprinc, Sprinc, 1, 2, 0, @@ -708,17 +707,36 @@ You can call print while debugging emacs, and pass it this function to make it write to the debugging output. */) (Lisp_Object character) { - CHECK_NUMBER (character); - putc (XINT (character) & 0xFF, stderr); + unsigned int ch; -#ifdef WINDOWSNT - /* Send the output to a debugger (nothing happens if there isn't one). */ - if (print_output_debug_flag) + CHECK_NUMBER (character); + ch = XINT (character); + if (ASCII_CHAR_P (ch)) { - char buf[2] = {(char) XINT (character), '\0'}; - OutputDebugString (buf); + putc (ch, stderr); +#ifdef WINDOWSNT + /* Send the output to a debugger (nothing happens if there isn't + one). */ + if (print_output_debug_flag) + { + char buf[2] = {(char) XINT (character), '\0'}; + OutputDebugString (buf); + } +#endif } + else + { + unsigned char mbstr[MAX_MULTIBYTE_LENGTH]; + ptrdiff_t len = CHAR_STRING (ch, mbstr); + Lisp_Object encoded_ch = + ENCODE_SYSTEM (make_multibyte_string ((char *) mbstr, 1, len)); + + fwrite (SSDATA (encoded_ch), SBYTES (encoded_ch), 1, stderr); +#ifdef WINDOWSNT + if (print_output_debug_flag) + OutputDebugString (SSDATA (encoded_ch)); #endif + } return character; } @@ -726,9 +744,9 @@ to make it write to the debugging output. */) /* This function is never called. Its purpose is to prevent print_output_debug_flag from being optimized away. */ -extern void debug_output_compilation_hack (int) EXTERNALLY_VISIBLE; +extern void debug_output_compilation_hack (bool) EXTERNALLY_VISIBLE; void -debug_output_compilation_hack (int x) +debug_output_compilation_hack (bool x) { print_output_debug_flag = x; } @@ -764,13 +782,12 @@ append to existing target file. */) { file = Fexpand_file_name (file, Qnil); initial_stderr_stream = stderr; - stderr = fopen (SSDATA (file), NILP (append) ? "w" : "a"); + stderr = emacs_fopen (SSDATA (file), NILP (append) ? "w" : "a"); if (stderr == NULL) { stderr = initial_stderr_stream; initial_stderr_stream = NULL; - report_file_error ("Cannot open debugging output stream", - Fcons (file, Qnil)); + report_file_error ("Cannot open debugging output stream", file); } } return Qnil; @@ -966,7 +983,7 @@ float_to_string (char *buf, double data) static char const NaN_string[] = "0.0e+NaN"; int i; union { double d; char c[sizeof (double)]; } u_data, u_minus_zero; - int negative = 0; + bool negative = 0; u_data.d = data; u_minus_zero.d = - 0.0; for (i = 0; i < sizeof (double); i++) @@ -1063,7 +1080,7 @@ float_to_string (char *buf, double data) static void -print (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag) +print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) { new_backquote_output = 0; @@ -1119,7 +1136,7 @@ print (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag) string (its text properties will be traced), or a symbol that has no obarray (this is for the print-gensym feature). The status fields of Vprint_number_table mean whether each object appears - more than once in OBJ: Qnil at the first time, and Qt after that . */ + more than once in OBJ: Qnil at the first time, and Qt after that. */ static void print_preprocess (Lisp_Object obj) { @@ -1300,7 +1317,7 @@ print_prune_string_charset (Lisp_Object string) if (print_check_string_result & PRINT_STRING_NON_CHARSET_FOUND) { if (NILP (print_prune_charset_plist)) - print_prune_charset_plist = Fcons (Qcharset, Qnil); + print_prune_charset_plist = list1 (Qcharset); Fremove_text_properties (make_number (0), make_number (SCHARS (string)), print_prune_charset_plist, string); @@ -1313,7 +1330,7 @@ print_prune_string_charset (Lisp_Object string) } static void -print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag) +print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) { char buf[max (sizeof "from..to..in " + 2 * INT_STRLEN_BOUND (EMACS_INT), max (sizeof " . #" + INT_STRLEN_BOUND (printmax_t), @@ -1389,14 +1406,13 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag print_string (obj, printcharfun); else { - register ptrdiff_t i_byte; + register ptrdiff_t i, i_byte; struct gcpro gcpro1; - unsigned char *str; ptrdiff_t size_byte; /* 1 means we must ensure that the next character we output cannot be taken as part of a hex character escape. */ - int need_nonhex = 0; - int multibyte = STRING_MULTIBYTE (obj); + bool need_nonhex = 0; + bool multibyte = STRING_MULTIBYTE (obj); GCPRO1 (obj); @@ -1410,23 +1426,15 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag } PRINTCHAR ('\"'); - str = SDATA (obj); size_byte = SBYTES (obj); - for (i_byte = 0; i_byte < 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 (multibyte) - { - c = STRING_CHAR_AND_LENGTH (str + i_byte, len); - i_byte += len; - } - else - c = str[i_byte++]; + FETCH_STRING_CHAR_ADVANCE (c, obj, i, i_byte); QUIT; @@ -1462,7 +1470,7 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag strout (outbuf, len, len, printcharfun); } else if (! multibyte - && SINGLE_BYTE_CHAR_P (c) && ! ASCII_BYTE_P (c) + && SINGLE_BYTE_CHAR_P (c) && ! ASCII_CHAR_P (c) && print_escape_nonascii) { /* When printing in a multibyte buffer @@ -1507,10 +1515,10 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag case Lisp_Symbol: { - register int confusing; - register unsigned char *p = SDATA (SYMBOL_NAME (obj)); - register unsigned char *end = p + SBYTES (SYMBOL_NAME (obj)); - register int c; + bool confusing; + unsigned char *p = SDATA (SYMBOL_NAME (obj)); + unsigned char *end = p + SBYTES (SYMBOL_NAME (obj)); + int c; ptrdiff_t i, i_byte; ptrdiff_t size_byte; Lisp_Object name; @@ -1704,15 +1712,14 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag int len; unsigned char c; struct gcpro gcpro1; - ptrdiff_t size_in_chars - = ((XBOOL_VECTOR (obj)->size + BOOL_VECTOR_BITS_PER_CHAR - 1) - / BOOL_VECTOR_BITS_PER_CHAR); - + EMACS_INT size = bool_vector_size (obj); + ptrdiff_t size_in_chars = bool_vector_bytes (size); + ptrdiff_t real_size_in_chars = size_in_chars; GCPRO1 (obj); PRINTCHAR ('#'); PRINTCHAR ('&'); - len = sprintf (buf, "%"pI"d", XBOOL_VECTOR (obj)->size); + len = sprintf (buf, "%"pI"d", size); strout (buf, len, len, printcharfun); PRINTCHAR ('\"'); @@ -1726,7 +1733,7 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag for (i = 0; i < size_in_chars; i++) { QUIT; - c = XBOOL_VECTOR (obj)->data[i]; + c = bool_vector_uchar_data (obj)[i]; if (c == '\n' && print_escape_newlines) { PRINTCHAR ('\\'); @@ -1752,6 +1759,9 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag PRINTCHAR (c); } } + + if (size_in_chars < real_size_in_chars) + strout (" ...", 4, 4, printcharfun); PRINTCHAR ('\"'); UNGCPRO; @@ -1768,10 +1778,10 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag strout ("#sequence_number); strout (buf, len, len, printcharfun); - if (!NILP (XWINDOW (obj)->buffer)) + if (BUFFERP (XWINDOW (obj)->contents)) { strout (" on ", -1, -1, printcharfun); - print_string (BVAR (XBUFFER (XWINDOW (obj)->buffer), name), + print_string (BVAR (XBUFFER (XWINDOW (obj)->contents), name), printcharfun); } PRINTCHAR ('>'); @@ -1797,6 +1807,7 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag ptrdiff_t real_size, size; int len; #if 0 + void *ptr = h; strout ("#test)) { @@ -1809,9 +1820,8 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag len = sprintf (buf, "%"pD"d/%"pD"d", h->count, ASIZE (h->next)); strout (buf, len, len, printcharfun); } - len = sprintf (buf, " %p", h); + len = sprintf (buf, " %p>", ptr); strout (buf, len, len, printcharfun); - PRINTCHAR ('>'); #endif /* Implement a readable output, e.g.: #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */ @@ -1891,6 +1901,7 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag else if (FRAMEP (obj)) { int len; + void *ptr = XFRAME (obj); Lisp_Object frame_name = XFRAME (obj)->name; strout ((FRAME_LIVE_P (XFRAME (obj)) @@ -1906,9 +1917,8 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag frame_name = build_string ("*INVALID*FRAME*NAME*"); } print_string (frame_name, printcharfun); - len = sprintf (buf, " %p", XFRAME (obj)); + len = sprintf (buf, " %p>", ptr); strout (buf, len, len, printcharfun); - PRINTCHAR ('>'); } else if (FONTP (obj)) { @@ -2027,8 +2037,9 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag PRINTCHAR ('>'); break; - /* Remaining cases shouldn't happen in normal usage, but let's print - them anyway for the benefit of the debugger. */ + /* 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, -1, printcharfun); break; @@ -2039,20 +2050,26 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag struct Lisp_Save_Value *v = XSAVE_VALUE (obj); strout ("#dogc) + + if (v->save_type == SAVE_TYPE_MEMORY) { - int lim = min (v->integer, 8); - - /* Try to print up to 8 objects we have saved. Although - valid_lisp_object_p is slow, this shouldn't be a real - bottleneck because such a saved values are quite rare. */ + ptrdiff_t amount = v->data[1].integer; + +#if GC_MARK_STACK - i = sprintf (buf, "with %"pD"d objects", v->integer); + /* valid_lisp_object_p is reliable, so try to print up + to 8 saved objects. This code is rarely used, so + it's OK that valid_lisp_object_p is slow. */ + + int limit = min (amount, 8); + Lisp_Object *area = v->data[0].pointer; + + i = sprintf (buf, "with %"pD"d objects", amount); strout (buf, i, i, printcharfun); - for (i = 0; i < lim; i++) + for (i = 0; i < limit; i++) { - Lisp_Object maybe = ((Lisp_Object *) v->pointer)[i]; + Lisp_Object maybe = area[i]; if (valid_lisp_object_p (maybe) > 0) { @@ -2062,13 +2079,61 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag else strout (" ", -1, -1, printcharfun); } - if (i == lim && i < v->integer) + if (i == limit && i < amount) strout (" ...", 4, 4, printcharfun); + +#else /* not GC_MARK_STACK */ + + /* There is no reliable way to determine whether the objects + are initialized, so do not try to print them. */ + + i = sprintf (buf, "with %"pD"d objects", amount); + strout (buf, i, i, printcharfun); + +#endif /* GC_MARK_STACK */ } else { - i = sprintf (buf, "ptr=%p int=%"pD"d", v->pointer, v->integer); - strout (buf, i, i, printcharfun); + /* Print each slot according to its type. */ + int index; + for (index = 0; index < SAVE_VALUE_SLOTS; index++) + { + if (index) + PRINTCHAR (' '); + + switch (save_type (v, index)) + { + case SAVE_UNUSED: + i = sprintf (buf, ""); + break; + + case SAVE_POINTER: + i = sprintf (buf, "", + v->data[index].pointer); + break; + + case SAVE_FUNCPOINTER: + i = sprintf (buf, "", + ((void *) (intptr_t) + v->data[index].funcpointer)); + break; + + case SAVE_INTEGER: + i = sprintf (buf, "", + v->data[index].integer); + break; + + case SAVE_OBJECT: + print_object (v->data[index].object, printcharfun, + escapeflag); + continue; + + default: + emacs_abort (); + } + + strout (buf, i, i, printcharfun); + } } PRINTCHAR ('>'); } @@ -2119,10 +2184,21 @@ print_interval (INTERVAL interval, Lisp_Object printcharfun) print_object (interval->plist, printcharfun, 1); } - +/* Initialize debug_print stuff early to have it working from the very + beginning. */ + +void +init_print_once (void) +{ + DEFSYM (Qexternal_debugging_output, "external-debugging-output"); + defsubr (&Sexternal_debugging_output); +} + void syms_of_print (void) { +#include "print.x" + DEFSYM (Qtemp_buffer_setup_hook, "temp-buffer-setup-hook"); DEFVAR_LISP ("standard-output", Vstandard_output, @@ -2244,19 +2320,6 @@ priorities. */); /* 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); - defsubr (&Swrite_char); - defsubr (&Sexternal_debugging_output); -#ifdef WITH_REDIRECT_DEBUGGING_OUTPUT - defsubr (&Sredirect_debugging_output); -#endif - - DEFSYM (Qexternal_debugging_output, "external-debugging-output"); DEFSYM (Qprint_escape_newlines, "print-escape-newlines"); DEFSYM (Qprint_escape_multibyte, "print-escape-multibyte"); DEFSYM (Qprint_escape_nonascii, "print-escape-nonascii");