/* 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;
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;
\f
/* Low level output routines for characters and strings. */
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)); \
+ bool free_print_buffer = 0; \
+ 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)
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;
}
else
{
- int multibyte_p
+ bool multibyte_p
= !NILP (BVAR (current_buffer, enable_multibyte_characters));
setup_echo_area_for_printing (multibyte_p);
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;
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);
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 ();
specbind (Qstandard_output, buf);
}
\f
-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.
(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);
}
/* 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;
}
{
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
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++)
\f
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;
{
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;
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))
{
}
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),
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);
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 ('(');
}
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 (')');
}
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;
if (escapeflag)
{
strout ("#<process ", -1, -1, printcharfun);
- print_string (PVAR (XPROCESS (obj), name), printcharfun);
+ print_string (XPROCESS (obj)->name, printcharfun);
PRINTCHAR ('>');
}
else
- print_string (PVAR (XPROCESS (obj), name), printcharfun);
+ print_string (XPROCESS (obj)->name, printcharfun);
}
else if (BOOL_VECTOR_P (obj))
{
{
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 (WVAR (XWINDOW (obj), buffer)))
+ if (BUFFERP (XWINDOW (obj)->contents))
{
strout (" on ", -1, -1, printcharfun);
- print_string (BVAR (XBUFFER (WVAR (XWINDOW (obj), buffer)), name),
+ print_string (BVAR (XBUFFER (XWINDOW (obj)->contents), name),
printcharfun);
}
PRINTCHAR ('>');
#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)
{
else if (FRAMEP (obj))
{
int len;
- Lisp_Object frame_name = FGET (XFRAME (obj), name);
+ Lisp_Object frame_name = XFRAME (obj)->name;
strout ((FRAME_LIVE_P (XFRAME (obj))
? "#<frame " : "#<dead frame "),
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->save_type == SAVE_TYPE_MEMORY)
+ {
+ ptrdiff_t amount = v->data[1].integer;
+
+#if GC_MARK_STACK
+
+ /* 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 < 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 */
+
+ /* 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
+ {
+ /* 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, "<unused>");
+ break;
+
+ case SAVE_POINTER:
+ i = sprintf (buf, "<pointer %p>",
+ v->data[index].pointer);
+ break;
+
+ case SAVE_INTEGER:
+ i = sprintf (buf, "<integer %"pD"d>",
+ v->data[index].integer);
+ break;
+
+ case SAVE_OBJECT:
+ print_object (v->data[index].object, printcharfun,
+ escapeflag);
+ continue;
+ }
+
+ strout (buf, i, i, printcharfun);
+ }
+ }
+ 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))
print_object (interval->plist, printcharfun, 1);
}
-\f
+/* 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)
{
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");