/* 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.
#include <config.h>
#include <stdio.h>
-#include <setjmp.h>
+
#include "lisp.h"
#include "character.h"
#include "buffer.h"
static Lisp_Object Qfloat_output_format;
-#include <math.h>
#include <float.h>
#include <ftoastr.h>
-/* 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;
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)); \
+ bool multibyte \
+ = !NILP (BVAR (current_buffer, enable_multibyte_characters)); \
Lisp_Object original
#define PRINTPREPARE \
? 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)
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;
- eassert (buffer_get_overlays (NULL, OV_BEFORE) == NULL);
- eassert (buffer_get_overlays (NULL, OV_AFTER) == NULL);
- BVAR (current_buffer, enable_multibyte_characters)
- = BVAR (&buffer_defaults, enable_multibyte_characters);
+ 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);
+ bset_enable_multibyte_characters
+ (current_buffer, BVAR (&buffer_defaults, enable_multibyte_characters));
specbind (Qinhibit_read_only, Qt);
specbind (Qinhibit_modification_hooks, Qt);
Ferase_buffer ();
(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 ();
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;
Vdeactivate_mark = save_deactivate_mark;
/* UNGCPRO; */
- abort_on_gc--;
+ abort_on_gc = prev_abort_on_gc;
return unbind_to (count, object);
}
{
if (initial_stderr_stream != NULL)
{
- BLOCK_INPUT;
+ block_input ();
fclose (stderr);
- UNBLOCK_INPUT;
+ unblock_input ();
}
stderr = initial_stderr_stream;
initial_stderr_stream = NULL;
else
fprintf (stderr, "#<%s_LISP_OBJECT 0x%08"pI"x>\r\n",
!valid ? "INVALID" : "SOME",
- XHASH (arg));
+ XLI (arg));
}
\f
{
case Lisp_String:
/* A string may have text properties, which can be circular. */
- traverse_intervals_noorder (string_get_intervals (obj),
+ traverse_intervals_noorder (string_intervals (obj),
print_preprocess_string, Qnil);
break;
print_prune_string_charset (Lisp_Object string)
{
print_check_string_result = 0;
- traverse_intervals (string_get_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))
{
/* 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 multibyte = STRING_MULTIBYTE (obj);
GCPRO1 (obj);
if (! EQ (Vprint_charset_text_property, Qt))
obj = print_prune_string_charset (obj);
- if (string_get_intervals (obj))
+ if (string_intervals (obj))
{
PRINTCHAR ('#');
PRINTCHAR ('(');
}
PRINTCHAR ('\"');
- if (string_get_intervals (obj))
+ if (string_intervals (obj))
{
- traverse_intervals (string_get_intervals (obj),
+ traverse_intervals (string_intervals (obj),
0, print_interval, printcharfun);
PRINTCHAR (')');
}
{
int len;
strout ("#<window ", -1, -1, printcharfun);
- len = sprintf (buf, "%d", XWINDOW (obj)->sequence_number);
+ len = sprintf (buf, "%p", XWINDOW (obj));
strout (buf, len, len, printcharfun);
if (!NILP (XWINDOW (obj)->buffer))
{
#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))
}
else if (BUFFERP (obj))
{
- if (NILP (BVAR (XBUFFER (obj), name)))
+ if (!BUFFER_LIVE_P (XBUFFER (obj)))
strout ("#<killed buffer>", -1, -1, printcharfun);
else if (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 ("#<misc free cell>", -1, -1, printcharfun);
break;
case Lisp_Misc_Save_Value:
- strout ("#<save_value ", -1, -1, printcharfun);
{
- int len = sprintf (buf, "ptr=%p int=%"pD"d",
- XSAVE_VALUE (obj)->pointer,
- XSAVE_VALUE (obj)->integer);
- strout (buf, len, len, printcharfun);
+ int i;
+ struct Lisp_Save_Value *v = XSAVE_VALUE (obj);
+
+ strout ("#<save-value ", -1, -1, printcharfun);
+
+ if (v->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 = 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 (" <invalid>", -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, "<unused>"); \
+ else if (v->type ## index == SAVE_INTEGER) \
+ i = sprintf (buf, "<integer %"pD"d>", v->data[index].integer); \
+ else if (v->type ## index == SAVE_POINTER) \
+ i = sprintf (buf, "<pointer %p>", 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:
{
int len;
/* We're in trouble if this happens!
- Probably should just abort () */
+ Probably should just emacs_abort (). */
strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun);
if (MISCP (obj))
len = sprintf (buf, "(MISC 0x%04x)", (int) XMISCTYPE (obj));
/* Print a description of INTERVAL using PRINTCHARFUN.
This is part of printing a string that has text properties. */
-void
+static void
print_interval (INTERVAL interval, Lisp_Object printcharfun)
{
if (NILP (interval->plist))
HCoop / bpt / emacs.git / blobdiff