X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/23f86fce48e1cc8118f0ea5cce49d1acfd4364c4..73ebd38f16c4799b657e501f188e9f3a3eca7805:/src/print.c?ds=sidebyside diff --git a/src/print.c b/src/print.c index b0189b9bc2..0ae83cdf6d 100644 --- a/src/print.c +++ b/src/print.c @@ -1,7 +1,7 @@ /* Lisp object printing and output streams. -Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2012 - Free Software Foundation, Inc. +Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2013 Free Software +Foundation, Inc. This file is part of GNU Emacs. @@ -21,7 +21,7 @@ along with GNU Emacs. If not, see . */ #include #include -#include + #include "lisp.h" #include "character.h" #include "buffer.h" @@ -45,15 +45,9 @@ static Lisp_Object Qtemp_buffer_setup_hook; static Lisp_Object Qfloat_output_format; -#include #include #include -/* Default to values appropriate for IEEE floating point. */ -#ifndef DBL_DIG -#define DBL_DIG 15 -#endif - /* Avoid actual stack overflow in print. */ static ptrdiff_t print_depth; @@ -173,8 +167,7 @@ int print_output_debug_flag EXTERNALLY_VISIBLE = 1; if (print_buffer_pos != print_buffer_pos_byte \ && NILP (BVAR (current_buffer, enable_multibyte_characters))) \ { \ - unsigned char *temp \ - = (unsigned char *) alloca (print_buffer_pos + 1); \ + unsigned char *temp = alloca (print_buffer_pos + 1); \ copy_text ((unsigned char *) print_buffer, temp, \ print_buffer_pos_byte, 1, 0); \ insert_1_both ((char *) temp, print_buffer_pos, \ @@ -198,8 +191,7 @@ int print_output_debug_flag EXTERNALLY_VISIBLE = 1; ? 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); #define PRINTCHAR(ch) printchar (ch, printcharfun) @@ -393,16 +385,14 @@ print_string (Lisp_Object string, Lisp_Object printcharfun) { /* Output to echo area. */ ptrdiff_t nbytes = SBYTES (string); - char *buffer; /* Copy the string contents so that relocation of STRING by GC does not cause trouble. */ USE_SAFE_ALLOCA; - - SAFE_ALLOCA (buffer, char *, nbytes); + char *buffer = SAFE_ALLOCA (nbytes); memcpy (buffer, SDATA (string), nbytes); - strout (buffer, chars, SBYTES (string), printcharfun); + strout (buffer, chars, nbytes, printcharfun); SAFE_FREE (); } @@ -491,20 +481,20 @@ temp_output_buffer_setup (const char *bufname) register struct buffer *old = current_buffer; register Lisp_Object buf; - record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ()); + record_unwind_current_buffer (); Fset_buffer (Fget_buffer_create (build_string (bufname))); Fkill_all_local_variables (); delete_all_overlays (current_buffer); - BVAR (current_buffer, directory) = BVAR (old, directory); - BVAR (current_buffer, read_only) = Qnil; - BVAR (current_buffer, filename) = Qnil; - BVAR (current_buffer, undo_list) = Qt; + bset_directory (current_buffer, BVAR (old, directory)); + bset_read_only (current_buffer, Qnil); + bset_filename (current_buffer, Qnil); + bset_undo_list (current_buffer, Qt); eassert (current_buffer->overlays_before == NULL); eassert (current_buffer->overlays_after == NULL); - BVAR (current_buffer, enable_multibyte_characters) - = BVAR (&buffer_defaults, enable_multibyte_characters); + bset_enable_multibyte_characters + (current_buffer, BVAR (&buffer_defaults, enable_multibyte_characters)); specbind (Qinhibit_read_only, Qt); specbind (Qinhibit_modification_hooks, Qt); Ferase_buffer (); @@ -589,6 +579,7 @@ A printed representation of an object is text which describes that object. */) (Lisp_Object object, Lisp_Object noescape) { Lisp_Object printcharfun; + bool prev_abort_on_gc; /* struct gcpro gcpro1, gcpro2; */ Lisp_Object save_deactivate_mark; ptrdiff_t count = SPECPDL_INDEX (); @@ -604,7 +595,8 @@ 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); */ - abort_on_gc++; + prev_abort_on_gc = abort_on_gc; + abort_on_gc = 1; printcharfun = Vprin1_to_string_buffer; PRINTPREPARE; @@ -628,7 +620,7 @@ A printed representation of an object is text which describes that object. */) Vdeactivate_mark = save_deactivate_mark; /* UNGCPRO; */ - abort_on_gc--; + abort_on_gc = prev_abort_on_gc; return unbind_to (count, object); } @@ -761,9 +753,9 @@ append to existing target file. */) { if (initial_stderr_stream != NULL) { - BLOCK_INPUT; + block_input (); fclose (stderr); - UNBLOCK_INPUT; + unblock_input (); } stderr = initial_stderr_stream; initial_stderr_stream = NULL; @@ -806,7 +798,7 @@ safe_debug_print (Lisp_Object arg) else fprintf (stderr, "#<%s_LISP_OBJECT 0x%08"pI"x>\r\n", !valid ? "INVALID" : "SOME", - XHASH (arg)); + XLI (arg)); } @@ -863,11 +855,11 @@ print_error_message (Lisp_Object data, Lisp_Object stream, const char *context, if (!NILP (caller) && SYMBOLP (caller)) { Lisp_Object cname = SYMBOL_NAME (caller); - char *name; + ptrdiff_t cnamelen = SBYTES (cname); USE_SAFE_ALLOCA; - SAFE_ALLOCA (name, char *, SBYTES (cname)); - memcpy (name, SDATA (cname), SBYTES (cname)); - message_dolog (name, SBYTES (cname), 0, 0); + char *name = SAFE_ALLOCA (cnamelen); + memcpy (name, SDATA (cname), cnamelen); + message_dolog (name, cnamelen, 0, 0); message_dolog (": ", 2, 0, 0); SAFE_FREE (); } @@ -1197,7 +1189,7 @@ print_preprocess (Lisp_Object obj) { case Lisp_String: /* A string may have text properties, which can be circular. */ - traverse_intervals_noorder (STRING_INTERVALS (obj), + traverse_intervals_noorder (string_intervals (obj), print_preprocess_string, Qnil); break; @@ -1300,7 +1292,7 @@ static Lisp_Object print_prune_string_charset (Lisp_Object string) { print_check_string_result = 0; - traverse_intervals (STRING_INTERVALS (string), 0, + traverse_intervals (string_intervals (string), 0, print_check_string_charset_prop, string); if (! (print_check_string_result & PRINT_STRING_UNSAFE_CHARSET_FOUND)) { @@ -1411,7 +1403,7 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag if (! EQ (Vprint_charset_text_property, Qt)) obj = print_prune_string_charset (obj); - if (!NULL_INTERVAL_P (STRING_INTERVALS (obj))) + if (string_intervals (obj)) { PRINTCHAR ('#'); PRINTCHAR ('('); @@ -1502,9 +1494,9 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag } PRINTCHAR ('\"'); - if (!NULL_INTERVAL_P (STRING_INTERVALS (obj))) + if (string_intervals (obj)) { - traverse_intervals (STRING_INTERVALS (obj), + traverse_intervals (string_intervals (obj), 0, print_interval, printcharfun); PRINTCHAR (')'); } @@ -1779,7 +1771,8 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag if (!NILP (XWINDOW (obj)->buffer)) { strout (" on ", -1, -1, printcharfun); - print_string (BVAR (XBUFFER (XWINDOW (obj)->buffer), name), printcharfun); + print_string (BVAR (XBUFFER (XWINDOW (obj)->buffer), name), + printcharfun); } PRINTCHAR ('>'); } @@ -1822,14 +1815,14 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag #endif /* Implement a readable output, e.g.: #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */ - /* Always print the size. */ + /* Always print the size. */ len = sprintf (buf, "#s(hash-table size %"pD"d", ASIZE (h->next)); strout (buf, len, len, printcharfun); - if (!NILP (h->test)) + if (!NILP (h->test.name)) { strout (" test ", -1, -1, printcharfun); - print_object (h->test, printcharfun, escapeflag); + print_object (h->test.name, printcharfun, escapeflag); } if (!NILP (h->weak)) @@ -1880,7 +1873,7 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag } else if (BUFFERP (obj)) { - if (NILP (BVAR (XBUFFER (obj), name))) + if (!BUFFER_LIVE_P (XBUFFER (obj))) strout ("#", -1, -1, printcharfun); else if (escapeflag) { @@ -1898,10 +1891,21 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag else if (FRAMEP (obj)) { int len; + Lisp_Object frame_name = XFRAME (obj)->name; + strout ((FRAME_LIVE_P (XFRAME (obj)) ? "#name, printcharfun); + if (!STRINGP (frame_name)) + { + /* A frame could be too young and have no name yet; + don't crash. */ + if (SYMBOLP (frame_name)) + frame_name = Fsymbol_name (frame_name); + else /* can't happen: name should be either nil or string */ + frame_name = build_string ("*INVALID*FRAME*NAME*"); + } + print_string (frame_name, printcharfun); len = sprintf (buf, " %p", XFRAME (obj)); strout (buf, len, len, printcharfun); PRINTCHAR ('>'); @@ -2023,21 +2027,96 @@ 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; case Lisp_Misc_Save_Value: - strout ("#pointer, - XSAVE_VALUE (obj)->integer); - strout (buf, len, len, printcharfun); + int i; + struct Lisp_Save_Value *v = XSAVE_VALUE (obj); + + strout ("#area) + { + ptrdiff_t amount = v->data[1].integer; + +#if GC_MARK_STACK + + /* If GC_MARK_STACK, valid_lisp_object_p is quite reliable, + and so we 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 we do not use this code under + normal circumstances. */ + + int limit = min (amount, 8); + Lisp_Object *area = (Lisp_Object *) v->data[0].pointer; + + i = sprintf (buf, "with %"pD"d objects", amount); + strout (buf, i, i, printcharfun); + + for (i = 0; i < limit; i++) + { + Lisp_Object maybe = area[i]; + + if (valid_lisp_object_p (maybe) > 0) + { + PRINTCHAR (' '); + print_object (maybe, printcharfun, escapeflag); + } + else + strout (" ", -1, -1, printcharfun); + } + if (i == limit && i < amount) + strout (" ...", 4, 4, printcharfun); + +#else /* not GC_MARK_STACK */ + + /* If !GC_MARK_STACK, we have no reliable way to find + whether Lisp_Object pointers points to an initialized + objects, and so we do not ever trying to print them. */ + + i = sprintf (buf, "with %"pD"d objects", amount); + strout (buf, i, i, printcharfun); + +#endif /* GC_MARK_STACK */ + } + else + { + /* Print each `data[N]' slot according to its type. */ + +#define PRINTX(index) \ + do { \ + i = 0; \ + if (v->type ## index == SAVE_UNUSED) \ + i = sprintf (buf, ""); \ + else if (v->type ## index == SAVE_INTEGER) \ + i = sprintf (buf, "", v->data[index].integer); \ + else if (v->type ## index == SAVE_POINTER) \ + i = sprintf (buf, "", v->data[index].pointer); \ + else /* SAVE_OBJECT */ \ + print_object (v->data[index].object, printcharfun, escapeflag); \ + if (i) \ + strout (buf, i, i, printcharfun); \ + } while (0) + + PRINTX (0); + PRINTCHAR (' '); + PRINTX (1); + PRINTCHAR (' '); + PRINTX (2); + PRINTCHAR (' '); + PRINTX (3); + +#undef PRINTX + + } + PRINTCHAR ('>'); } - PRINTCHAR ('>'); break; default: @@ -2050,7 +2129,7 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag { int len; /* We're in trouble if this happens! - Probably should just abort () */ + Probably should just emacs_abort (). */ strout ("#plist))