/* Lisp object printing and output streams.
Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997,
1998, 1999, 2000, 2001, 2002, 2003, 2004,
- 2005, 2006 Free Software Foundation, Inc.
+ 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
This file is part of GNU Emacs.
GNU Emacs is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
+the Free Software Foundation; either version 3, or (at your option)
any later version.
GNU Emacs is distributed in the hope that it will be useful,
#include "dispextern.h"
#include "termchar.h"
#include "intervals.h"
+#include "blockinput.h"
+#include "termhooks.h" /* For struct terminal. */
Lisp_Object Vstandard_output, Qstandard_output;
/* Avoid actual stack overflow in print. */
int print_depth;
-/* Nonzero if inside outputting backquote in old style. */
-int old_backquote_output;
+/* Level of nesting inside outputting backquote in new style. */
+int new_backquote_output;
/* Detect most circularities to print finite output. */
#define PRINT_CIRCLE 200
if (MARKERP (printcharfun)) \
{ \
EMACS_INT marker_pos; \
- if (!(XMARKER (printcharfun)->buffer)) \
+ if (! XMARKER (printcharfun)->buffer) \
error ("Marker does not point anywhere"); \
if (XMARKER (printcharfun)->buffer != current_buffer) \
set_buffer_internal (XMARKER (printcharfun)->buffer); \
SET_PT_BOTH (old_point + (old_point >= start_point \
? PT - start_point : 0), \
old_point_byte + (old_point_byte >= start_point_byte \
- ? PT_BYTE - start_point_byte : 0)); \
+ ? PT_BYTE - start_point_byte : 0)); \
if (old != current_buffer) \
set_buffer_internal (old);
print_buffer. PRINTCHARFUN t means output to the echo area or to
stdout if non-interactive. If neither nil nor t, call Lisp
function PRINTCHARFUN for each character printed. MULTIBYTE
- non-zero means PTR contains multibyte characters. */
+ non-zero means PTR contains multibyte characters.
+
+ In the case where PRINTCHARFUN is nil, it is safe for PTR to point
+ to data in a Lisp string. Otherwise that is not safe. */
static void
strout (ptr, size, size_byte, printcharfun, multibyte)
if (size == size_byte)
{
for (i = 0; i < size; ++i)
- insert_char ((unsigned char )*ptr++);
+ insert_char ((unsigned char) *ptr++);
}
else
{
else
chars = SBYTES (string);
- /* strout is safe for output to a frame (echo area) or to print_buffer. */
- strout (SDATA (string),
- chars, SBYTES (string),
- printcharfun, STRING_MULTIBYTE (string));
+ if (EQ (printcharfun, Qt))
+ {
+ /* Output to echo area. */
+ int 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);
+ bcopy (SDATA (string), buffer, nbytes);
+
+ strout (buffer, chars, SBYTES (string),
+ printcharfun, STRING_MULTIBYTE (string));
+
+ SAFE_FREE ();
+ }
+ else
+ /* No need to copy, since output to print_buffer can't GC. */
+ strout (SDATA (string),
+ chars, SBYTES (string),
+ printcharfun, STRING_MULTIBYTE (string));
}
else
{
Fwith_output_to_temp_buffer, Swith_output_to_temp_buffer,
1, UNEVALLED, 0,
doc: /* Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
-The buffer is cleared out initially, and marked as unmodified when done.
-All output done by BODY is inserted in that buffer by default.
-The buffer is displayed in another window, but not selected.
-The value of the last form in BODY is returned.
-If BODY does not finish normally, the buffer BUFNAME is not displayed.
-
-The hook `temp-buffer-setup-hook' is run before BODY,
-with the buffer BUFNAME temporarily current.
-The hook `temp-buffer-show-hook' is run after the buffer is displayed,
-with the buffer temporarily current, and the window that was used
-to display it temporarily selected.
-
-If variable `temp-buffer-show-function' is non-nil, call it at the end
-to get the buffer displayed instead of just displaying the non-selected
-buffer and calling the hook. It gets one argument, the buffer to display.
-
-usage: (with-output-to-temp-buffer BUFNAME BODY ...) */)
+
+This construct makes buffer BUFNAME empty before running BODY.
+It does not make the buffer current for BODY.
+Instead it binds `standard-output' to that buffer, so that output
+generated with `prin1' and similar functions in BODY goes into
+the buffer.
+
+At the end of BODY, this marks buffer BUFNAME unmodifed and displays
+it in a window, but does not select it. The normal way to do this is
+by calling `display-buffer', then running `temp-buffer-show-hook'.
+However, if `temp-buffer-show-function' is non-nil, it calls that
+function instead (and does not run `temp-buffer-show-hook'). The
+function gets one argument, the buffer to display.
+
+The return value of `with-output-to-temp-buffer' is the value of the
+last form in BODY. If BODY does not finish normally, the buffer
+BUFNAME is not displayed.
+
+This runs the hook `temp-buffer-setup-hook' before BODY,
+with the buffer BUFNAME temporarily current. It runs the hook
+`temp-buffer-show-hook' after displaying buffer BUFNAME, with that
+buffer temporarily current, and the window that was used to display it
+temporarily selected. But it doesn't run `temp-buffer-show-hook'
+if it uses `temp-buffer-show-function'.
+
+usage: (with-output-to-temp-buffer BUFNAME BODY...) */)
(args)
Lisp_Object args;
{
Lisp_Object printcharfun;
/* struct gcpro gcpro1, gcpro2; */
Lisp_Object save_deactivate_mark;
- int count = specpdl_ptr - specpdl;
+ int count = SPECPDL_INDEX ();
struct buffer *previous;
specbind (Qinhibit_modification_hooks, Qt);
return character;
}
+/* This function is never called. Its purpose is to prevent
+ print_output_debug_flag from being optimized away. */
-#if defined(GNU_LINUX)
+void
+debug_output_compilation_hack (x)
+ int x;
+{
+ print_output_debug_flag = x;
+}
+
+#if defined (GNU_LINUX)
/* This functionality is not vitally important in general, so we rely on
non-portable ability to use stderr as lvalue. */
Lisp_Object file, append;
{
if (initial_stderr_stream != NULL)
- fclose(stderr);
+ {
+ BLOCK_INPUT;
+ fclose (stderr);
+ UNBLOCK_INPUT;
+ }
stderr = initial_stderr_stream;
initial_stderr_stream = NULL;
{
file = Fexpand_file_name (file, Qnil);
initial_stderr_stream = stderr;
- stderr = fopen(SDATA (file), NILP (append) ? "w" : "a");
+ stderr = fopen (SDATA (file), NILP (append) ? "w" : "a");
if (stderr == NULL)
{
stderr = initial_stderr_stream;
else
fprintf (stderr, "#<%s_LISP_OBJECT 0x%08lx>\r\n",
!valid ? "INVALID" : "SOME",
-#ifdef NO_UNION_TYPE
- (unsigned long) arg
-#else
- (unsigned long) arg.i
-#endif
+ (unsigned long) XHASH (arg)
);
}
register Lisp_Object printcharfun;
int escapeflag;
{
- old_backquote_output = 0;
+ new_backquote_output = 0;
/* Reset print_number_index and Vprint_number_table only when
the variable Vprint_continuous_numbering is nil. Otherwise,
the values of these variables will be kept between several
print functions. */
- if (NILP (Vprint_continuous_numbering))
+ if (NILP (Vprint_continuous_numbering)
+ || NILP (Vprint_number_table))
{
print_number_index = 0;
Vprint_number_table = Qnil;
{
case Lisp_Int:
if (sizeof (int) == sizeof (EMACS_INT))
- sprintf (buf, "%d", XINT (obj));
+ sprintf (buf, "%d", (int) XINT (obj));
else if (sizeof (long) == sizeof (EMACS_INT))
sprintf (buf, "%ld", (long) XINT (obj));
else
print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
}
else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
- && ! old_backquote_output
+ && ((EQ (XCAR (obj), Qbackquote))))
+ {
+ print_object (XCAR (obj), printcharfun, 0);
+ new_backquote_output++;
+ print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
+ new_backquote_output--;
+ }
+ else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
+ && new_backquote_output
&& ((EQ (XCAR (obj), Qbackquote)
|| EQ (XCAR (obj), Qcomma)
|| EQ (XCAR (obj), Qcomma_at)
|| EQ (XCAR (obj), Qcomma_dot))))
{
print_object (XCAR (obj), printcharfun, 0);
+ new_backquote_output--;
print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
+ new_backquote_output++;
}
else
{
print_object (Qbackquote, printcharfun, 0);
PRINTCHAR (' ');
- ++old_backquote_output;
print_object (XCAR (XCDR (tem)), printcharfun, 0);
- --old_backquote_output;
PRINTCHAR (')');
obj = XCDR (obj);
}
PRINTCHAR ('>');
}
+ else if (TERMINALP (obj))
+ {
+ struct terminal *t = XTERMINAL (obj);
+ strout ("#<terminal ", -1, -1, printcharfun, 0);
+ sprintf (buf, "%d", t->id);
+ strout (buf, -1, -1, printcharfun, 0);
+ if (t->name)
+ {
+ strout (" on ", -1, -1, printcharfun, 0);
+ strout (t->name, -1, -1, printcharfun, 0);
+ }
+ PRINTCHAR ('>');
+ }
else if (HASH_TABLE_P (obj))
{
struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
PRINTCHAR (' ');
strout (SDATA (SYMBOL_NAME (h->weak)), -1, -1, printcharfun, 0);
PRINTCHAR (' ');
- sprintf (buf, "%ld/%ld", (long) XFASTINT (h->count),
+ sprintf (buf, "%ld/%ld", (long) h->count,
(long) XVECTOR (h->next)->size);
strout (buf, -1, -1, printcharfun, 0);
}
/* Do you think this is necessary? */
if (XMARKER (obj)->insertion_type != 0)
strout ("(moves after insertion) ", -1, -1, printcharfun, 0);
- if (!(XMARKER (obj)->buffer))
+ if (! XMARKER (obj)->buffer)
strout ("in no buffer", -1, -1, printcharfun, 0);
else
{
case Lisp_Misc_Overlay:
strout ("#<overlay ", -1, -1, printcharfun, 0);
- if (!(XMARKER (OVERLAY_START (obj))->buffer))
+ if (! XMARKER (OVERLAY_START (obj))->buffer)
strout ("in no buffer", -1, -1, printcharfun, 0);
else
{
case Lisp_Misc_Kboard_Objfwd:
strout ("#<kboard_objfwd to ", -1, -1, printcharfun, 0);
- print_object (*(Lisp_Object *)((char *) current_kboard
- + XKBOARD_OBJFWD (obj)->offset),
+ print_object (*(Lisp_Object *) ((char *) current_kboard
+ + XKBOARD_OBJFWD (obj)->offset),
printcharfun, escapeflag);
PRINTCHAR ('>');
break;
case Lisp_Misc_Buffer_Local_Value:
strout ("#<buffer_local_value ", -1, -1, printcharfun, 0);
- goto do_buffer_local;
- case Lisp_Misc_Some_Buffer_Local_Value:
- strout ("#<some_buffer_local_value ", -1, -1, printcharfun, 0);
- do_buffer_local:
+ if (XBUFFER_LOCAL_VALUE (obj)->local_if_set)
+ strout ("[local-if-set] ", -1, -1, printcharfun, 0);
strout ("[realvalue] ", -1, -1, printcharfun, 0);
print_object (XBUFFER_LOCAL_VALUE (obj)->realvalue,
printcharfun, escapeflag);
print_object (make_number (interval->position), printcharfun, 1);
PRINTCHAR (' ');
print_object (make_number (interval->position + LENGTH (interval)),
- printcharfun, 1);
+ printcharfun, 1);
PRINTCHAR (' ');
print_object (interval->plist, printcharfun, 1);
}
HCoop / bpt / emacs.git / blobdiff