/* Lisp object printing and output streams.
- Copyright (C) 1985, 1986, 1988, 1993, 1994 Free Software Foundation, Inc.
+ Copyright (C) 1985, 86, 88, 93, 94, 95 Free Software Foundation, Inc.
This file is part of GNU Emacs.
You should have received a copy of the GNU General Public License
along with GNU Emacs; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
#include <config.h>
#include <stdio.h>
-#undef NULL
#include "lisp.h"
#ifndef standalone
#include "process.h"
#include "dispextern.h"
#include "termchar.h"
+#include "keyboard.h"
#endif /* not standalone */
#ifdef USE_TEXT_PROPERTIES
Lisp_Object Qprint_escape_newlines;
-/* Nonzero means print newline before next minibuffer message.
+/* Nonzero means print newline to stdout before next minibuffer message.
Defined in xdisp.c */
extern int noninteractive_need_newline;
+
#ifdef MAX_PRINT_CHARS
static int print_chars;
static int max_print;
#define PRINTPREPARE \
original = printcharfun; \
if (NILP (printcharfun)) printcharfun = Qt; \
- if (XTYPE (printcharfun) == Lisp_Buffer) \
+ if (BUFFERP (printcharfun)) \
{ if (XBUFFER (printcharfun) != current_buffer) \
Fset_buffer (printcharfun); \
printcharfun = Qnil;} \
- if (XTYPE (printcharfun) == Lisp_Marker) \
+ if (MARKERP (printcharfun)) \
{ if (!(XMARKER (original)->buffer)) \
error ("Marker does not point anywhere"); \
if (XMARKER (original)->buffer != current_buffer) \
printcharfun = Qnil;}
#define PRINTFINISH \
- if (XTYPE (original) == Lisp_Marker) \
+ if (MARKERP (original)) \
Fset_marker (original, make_number (point), Qnil); \
if (old_point >= 0) \
SET_PT (old_point + (old_point >= start_point \
if (EQ (fun, Qt))
{
- struct frame *mini_frame
+ FRAME_PTR mini_frame
= XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window)));
if (noninteractive)
if (echo_area_glyphs != FRAME_MESSAGE_BUF (mini_frame)
|| !message_buf_print)
{
+ message_log_maybe_newline ();
echo_area_glyphs = FRAME_MESSAGE_BUF (mini_frame);
printbufidx = 0;
echo_area_glyphs_length = 0;
message_buf_print = 1;
}
+ message_dolog (&ch, 1, 0);
if (printbufidx < FRAME_WIDTH (mini_frame) - 1)
FRAME_MESSAGE_BUF (mini_frame)[printbufidx++] = ch;
FRAME_MESSAGE_BUF (mini_frame)[printbufidx] = 0;
}
#endif /* not standalone */
- XFASTINT (ch1) = ch;
+ XSETFASTINT (ch1, ch);
call1 (fun, ch1);
}
}
if (EQ (printcharfun, Qt))
{
- struct frame *mini_frame
+ FRAME_PTR mini_frame
= XFRAME (WINDOW_FRAME (XWINDOW (minibuf_window)));
i = size >= 0 ? size : strlen (ptr);
if (echo_area_glyphs != FRAME_MESSAGE_BUF (mini_frame)
|| !message_buf_print)
{
+ message_log_maybe_newline ();
echo_area_glyphs = FRAME_MESSAGE_BUF (mini_frame);
printbufidx = 0;
echo_area_glyphs_length = 0;
message_buf_print = 1;
}
+ message_dolog (ptr, i, 0);
if (i > FRAME_WIDTH (mini_frame) - printbufidx - 1)
i = FRAME_WIDTH (mini_frame) - printbufidx - 1;
bcopy (ptr, &FRAME_MESSAGE_BUF (mini_frame) [printbufidx], i);
}
/* Print the contents of a string STRING using PRINTCHARFUN.
- It isn't safe to use strout, because printing one char can relocate. */
+ It isn't safe to use strout in many cases,
+ because printing one char can relocate. */
print_string (string, printcharfun)
Lisp_Object string;
Lisp_Object printcharfun;
{
- if (EQ (printcharfun, Qnil) || EQ (printcharfun, Qt))
- /* In predictable cases, strout is safe: output to buffer or frame. */
+ if (EQ (printcharfun, Qt))
+ /* strout is safe for output to a frame (echo area). */
strout (XSTRING (string)->data, XSTRING (string)->size, printcharfun);
+ else if (EQ (printcharfun, Qnil))
+ {
+#ifdef MAX_PRINT_CHARS
+ if (max_print)
+ print_chars += XSTRING (string)->size;
+#endif /* MAX_PRINT_CHARS */
+ insert_from_string (string, 0, XSTRING (string)->size, 1);
+ }
else
{
/* Otherwise, fetch the string address for each character. */
}
\f
DEFUN ("write-char", Fwrite_char, Swrite_char, 1, 2, 0,
- "Output character CHAR to stream STREAM.\n\
-STREAM defaults to the value of `standard-output' (which see).")
- (ch, printcharfun)
- Lisp_Object ch, printcharfun;
+ "Output character CHARACTER to stream PRINTCHARFUN.\n\
+PRINTCHARFUN defaults to the value of `standard-output' (which see).")
+ (character, printcharfun)
+ Lisp_Object character, printcharfun;
{
struct buffer *old = current_buffer;
int old_point = -1;
if (NILP (printcharfun))
printcharfun = Vstandard_output;
- CHECK_NUMBER (ch, 0);
+ CHECK_NUMBER (character, 0);
PRINTPREPARE;
- PRINTCHAR (XINT (ch));
+ PRINTCHAR (XINT (character));
PRINTFINISH;
- return ch;
+ return character;
}
/* Used from outside of print.c to print a block of SIZE chars at DATA
Fset_buffer (Fget_buffer_create (build_string (bufname)));
+ current_buffer->directory = old->directory;
current_buffer->read_only = Qnil;
Ferase_buffer ();
- XSET (buf, Lisp_Buffer, current_buffer);
+ XSETBUFFER (buf, current_buffer);
specbind (Qstandard_output, buf);
set_buffer_internal (old);
{
int count = specpdl_ptr - specpdl;
Lisp_Object buf, val;
+ struct gcpro gcpro1;
+ GCPRO1 (args);
record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
temp_output_buffer_setup (bufname);
buf = Vstandard_output;
+ UNGCPRO;
val = (*function) (args);
+ GCPRO1 (val);
temp_output_buffer_show (buf);
+ UNGCPRO;
return unbind_to (count, val);
}
static void print ();
DEFUN ("terpri", Fterpri, Sterpri, 0, 1, 0,
- "Output a newline to STREAM.\n\
-If STREAM is omitted or nil, the value of `standard-output' is used.")
+ "Output a newline to stream PRINTCHARFUN.\n\
+If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used.")
(printcharfun)
Lisp_Object printcharfun;
{
"Output the printed representation of OBJECT, any Lisp object.\n\
Quoting characters are printed when needed to make output that `read'\n\
can handle, whenever this is possible.\n\
-Output stream is STREAM, or value of `standard-output' (which see).")
- (obj, printcharfun)
- Lisp_Object obj, printcharfun;
+Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
+ (object, printcharfun)
+ Lisp_Object object, printcharfun;
{
struct buffer *old = current_buffer;
int old_point = -1;
printcharfun = Vstandard_output;
PRINTPREPARE;
print_depth = 0;
- print (obj, printcharfun, 1);
+ print (object, printcharfun, 1);
PRINTFINISH;
- return obj;
+ return object;
}
/* a buffer which is used to hold output being built by prin1-to-string */
any Lisp object. Quoting characters are used when needed to make output\n\
that `read' can handle, whenever this is possible, unless the optional\n\
second argument NOESCAPE is non-nil.")
- (obj, noescape)
- Lisp_Object obj, noescape;
+ (object, noescape)
+ Lisp_Object object, noescape;
{
struct buffer *old = current_buffer;
int old_point = -1;
int start_point;
Lisp_Object original, printcharfun;
- struct gcpro gcpro1;
+ struct gcpro gcpro1, gcpro2;
+ Lisp_Object tem;
+
+ /* Save and restore this--we are altering a buffer
+ but we don't want to deactivate the mark just for that.
+ No need for specbind, since errors deactivate the mark. */
+ tem = Vdeactivate_mark;
+ GCPRO2 (object, tem);
printcharfun = Vprin1_to_string_buffer;
PRINTPREPARE;
print_depth = 0;
- print (obj, printcharfun, NILP (noescape));
+ print (object, printcharfun, NILP (noescape));
/* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
PRINTFINISH;
set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
- obj = Fbuffer_string ();
+ object = Fbuffer_string ();
- GCPRO1 (obj);
Ferase_buffer ();
set_buffer_internal (old);
+
+ Vdeactivate_mark = tem;
UNGCPRO;
- return obj;
+ return object;
}
DEFUN ("princ", Fprinc, Sprinc, 1, 2, 0,
"Output the printed representation of OBJECT, any Lisp object.\n\
No quoting characters are used; no delimiters are printed around\n\
the contents of strings.\n\
-Output stream is STREAM, or value of standard-output (which see).")
- (obj, printcharfun)
- Lisp_Object obj, printcharfun;
+Output stream is PRINTCHARFUN, or value of standard-output (which see).")
+ (object, printcharfun)
+ Lisp_Object object, printcharfun;
{
struct buffer *old = current_buffer;
int old_point = -1;
printcharfun = Vstandard_output;
PRINTPREPARE;
print_depth = 0;
- print (obj, printcharfun, 0);
+ print (object, printcharfun, 0);
PRINTFINISH;
- return obj;
+ return object;
}
DEFUN ("print", Fprint, Sprint, 1, 2, 0,
"Output the printed representation of OBJECT, with newlines around it.\n\
Quoting characters are printed when needed to make output that `read'\n\
can handle, whenever this is possible.\n\
-Output stream is STREAM, or value of `standard-output' (which see).")
- (obj, printcharfun)
- Lisp_Object obj, printcharfun;
+Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
+ (object, printcharfun)
+ Lisp_Object object, printcharfun;
{
struct buffer *old = current_buffer;
int old_point = -1;
#endif /* MAX_PRINT_CHARS */
if (NILP (printcharfun))
printcharfun = Vstandard_output;
- GCPRO1 (obj);
+ GCPRO1 (object);
PRINTPREPARE;
print_depth = 0;
PRINTCHAR ('\n');
- print (obj, printcharfun, 1);
+ print (object, printcharfun, 1);
PRINTCHAR ('\n');
PRINTFINISH;
#ifdef MAX_PRINT_CHARS
print_chars = 0;
#endif /* MAX_PRINT_CHARS */
UNGCPRO;
- return obj;
+ return object;
}
/* The subroutine object for external-debugging-output is kept here
return character;
}
+
+/* This is the interface for debugging printing. */
+
+void
+debug_print (arg)
+ Lisp_Object arg;
+{
+ Fprin1 (arg, Qexternal_debugging_output);
+ fprintf (stderr, "\r\n");
+}
+\f
+DEFUN ("error-message-string", Ferror_message_string, Serror_message_string,
+ 1, 1, 0,
+ "Convert an error value (ERROR-SYMBOL . DATA) to an error message.")
+ (obj)
+ Lisp_Object obj;
+{
+ struct buffer *old = current_buffer;
+ Lisp_Object original, printcharfun, value;
+ struct gcpro gcpro1;
+
+ print_error_message (obj, Vprin1_to_string_buffer, NULL);
+
+ set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
+ value = Fbuffer_string ();
+
+ GCPRO1 (value);
+ Ferase_buffer ();
+ set_buffer_internal (old);
+ UNGCPRO;
+
+ return value;
+}
+
+/* Print an error message for the error DATA
+ onto Lisp output stream STREAM (suitable for the print functions). */
+
+print_error_message (data, stream)
+ Lisp_Object data, stream;
+{
+ Lisp_Object errname, errmsg, file_error, tail;
+ struct gcpro gcpro1;
+ int i;
+
+ errname = Fcar (data);
+
+ if (EQ (errname, Qerror))
+ {
+ data = Fcdr (data);
+ if (!CONSP (data)) data = Qnil;
+ errmsg = Fcar (data);
+ file_error = Qnil;
+ }
+ else
+ {
+ errmsg = Fget (errname, Qerror_message);
+ file_error = Fmemq (Qfile_error,
+ Fget (errname, Qerror_conditions));
+ }
+
+ /* Print an error message including the data items. */
+
+ tail = Fcdr_safe (data);
+ GCPRO1 (tail);
+
+ /* For file-error, make error message by concatenating
+ all the data items. They are all strings. */
+ if (!NILP (file_error) && !NILP (tail))
+ errmsg = XCONS (tail)->car, tail = XCONS (tail)->cdr;
+
+ if (STRINGP (errmsg))
+ Fprinc (errmsg, stream);
+ else
+ write_string_1 ("peculiar error", -1, stream);
+
+ for (i = 0; CONSP (tail); tail = Fcdr (tail), i++)
+ {
+ write_string_1 (i ? ", " : ": ", 2, stream);
+ if (!NILP (file_error))
+ Fprinc (Fcar (tail), stream);
+ else
+ Fprin1 (Fcar (tail), stream);
+ }
+ UNGCPRO;
+}
\f
#ifdef LISP_FLOAT_TYPE
/*
* The buffer should be at least as large as the max string size of the
- * largest float, printed in the biggest notation. This is undoubtably
+ * largest float, printed in the biggest notation. This is undoubtedly
* 20d float_output_format, with the negative of the C-constant "HUGE"
* from <math.h>.
*
int width;
if (NILP (Vfloat_output_format)
- || XTYPE (Vfloat_output_format) != Lisp_String)
+ || !STRINGP (Vfloat_output_format))
lose:
{
sprintf (buf, "%.17g", data);
/* Check the width specification. */
width = -1;
if ('0' <= *cp && *cp <= '9')
- for (width = 0; (*cp >= '0' && *cp <= '9'); cp++)
- width = (width * 10) + (*cp - '0');
+ {
+ width = 0;
+ do
+ width = (width * 10) + (*cp++ - '0');
+ while (*cp >= '0' && *cp <= '9');
+
+ /* A precision of zero is valid only for %f. */
+ if (width > DBL_DIG
+ || (width == 0 && *cp != 'f'))
+ goto lose;
+ }
if (*cp != 'e' && *cp != 'f' && *cp != 'g')
goto lose;
- /* A precision of zero is valid for %f; everything else requires
- at least one. Width may be omitted anywhere. */
- if (width != -1
- && (width < (*cp != 'f')
- || width > DBL_DIG))
- goto lose;
-
if (cp[1] != 0)
goto lose;
#if 1 /* I'm not sure this is really worth doing. */
/* Detect circularities and truncate them.
No need to offer any alternative--this is better than an error. */
- if (XTYPE (obj) == Lisp_Cons || XTYPE (obj) == Lisp_Vector
- || XTYPE (obj) == Lisp_Compiled)
+ if (CONSP (obj) || VECTORP (obj) || COMPILEDP (obj))
{
int i;
for (i = 0; i < print_depth; i++)
}
#endif /* MAX_PRINT_CHARS */
-#ifdef SWITCH_ENUM_BUG
- switch ((int) XTYPE (obj))
-#else
- switch (XTYPE (obj))
-#endif
+ switch (XGCTYPE (obj))
{
- default:
- /* We're in trouble if this happens!
- Probably should just abort () */
- strout ("#<EMACS BUG: INVALID DATATYPE ", -1, printcharfun);
- sprintf (buf, "(#o%3o)", (int) XTYPE (obj));
+ case Lisp_Int:
+ if (sizeof (int) == sizeof (EMACS_INT))
+ sprintf (buf, "%d", XINT (obj));
+ else if (sizeof (long) == sizeof (EMACS_INT))
+ sprintf (buf, "%ld", XINT (obj));
+ else
+ abort ();
strout (buf, -1, printcharfun);
- strout (" Save your buffers immediately and please report this bug>",
- -1, printcharfun);
break;
#ifdef LISP_FLOAT_TYPE
strout (pigbuf, -1, printcharfun);
}
break;
-#endif /* LISP_FLOAT_TYPE */
-
- case Lisp_Int:
- sprintf (buf, "%d", XINT (obj));
- strout (buf, -1, printcharfun);
- break;
+#endif
case Lisp_String:
if (!escapeflag)
register unsigned char c;
if (p != end && (*p == '-' || *p == '+')) p++;
- if (p == end)
+ if (p == end)
confusing = 0;
else
{
case Lisp_Cons:
/* If deeper than spec'd depth, print placeholder. */
- if (XTYPE (Vprint_level) == Lisp_Int
+ if (INTEGERP (Vprint_level)
&& print_depth > XINT (Vprint_level))
+ strout ("...", -1, printcharfun);
+ else
{
- strout ("...", -1, printcharfun);
- break;
- }
-
- PRINTCHAR ('(');
- {
- register int i = 0;
- register int max = 0;
-
- if (XTYPE (Vprint_length) == Lisp_Int)
- max = XINT (Vprint_length);
- /* Could recognize circularities in cdrs here,
- but that would make printing of long lists quadratic.
- It's not worth doing. */
- while (CONSP (obj))
+ PRINTCHAR ('(');
{
- if (i++)
- PRINTCHAR (' ');
- if (max && i > max)
+ register int i = 0;
+ register int max = 0;
+
+ if (INTEGERP (Vprint_length))
+ max = XINT (Vprint_length);
+ /* Could recognize circularities in cdrs here,
+ but that would make printing of long lists quadratic.
+ It's not worth doing. */
+ while (CONSP (obj))
{
- strout ("...", 3, printcharfun);
- break;
+ if (i++)
+ PRINTCHAR (' ');
+ if (max && i > max)
+ {
+ strout ("...", 3, printcharfun);
+ break;
+ }
+ print (Fcar (obj), printcharfun, escapeflag);
+ obj = Fcdr (obj);
}
- print (Fcar (obj), printcharfun, escapeflag);
- obj = Fcdr (obj);
}
- }
- if (!NILP (obj) && !CONSP (obj))
- {
- strout (" . ", 3, printcharfun);
- print (obj, printcharfun, escapeflag);
+ if (!NILP (obj) && !CONSP (obj))
+ {
+ strout (" . ", 3, printcharfun);
+ print (obj, printcharfun, escapeflag);
+ }
+ PRINTCHAR (')');
}
- PRINTCHAR (')');
break;
- case Lisp_Compiled:
- strout ("#", -1, printcharfun);
- case Lisp_Vector:
- PRINTCHAR ('[');
- {
- register int i;
- register Lisp_Object tem;
- for (i = 0; i < XVECTOR (obj)->size; i++)
- {
- if (i) PRINTCHAR (' ');
- tem = XVECTOR (obj)->contents[i];
- print (tem, printcharfun, escapeflag);
- }
- }
- PRINTCHAR (']');
- break;
+ case Lisp_Vectorlike:
+ if (PROCESSP (obj))
+ {
+ if (escapeflag)
+ {
+ strout ("#<process ", -1, printcharfun);
+ print_string (XPROCESS (obj)->name, printcharfun);
+ PRINTCHAR ('>');
+ }
+ else
+ print_string (XPROCESS (obj)->name, printcharfun);
+ }
+ else if (BOOL_VECTOR_P (obj))
+ {
+ register int i;
+ register unsigned char c;
+ struct gcpro gcpro1;
+ int size_in_chars
+ = (XBOOL_VECTOR (obj)->size + BITS_PER_CHAR) / BITS_PER_CHAR;
+
+ GCPRO1 (obj);
+ PRINTCHAR ('#');
+ PRINTCHAR ('&');
+ sprintf (buf, "%d", XBOOL_VECTOR (obj)->size);
+ strout (buf, -1, printcharfun);
+ PRINTCHAR ('\"');
+
+ /* Don't print more characters than the specified maximum. */
+ if (INTEGERP (Vprint_length)
+ && XINT (Vprint_length) < size_in_chars)
+ size_in_chars = XINT (Vprint_length);
+
+ for (i = 0; i < size_in_chars; i++)
+ {
+ QUIT;
+ c = XBOOL_VECTOR (obj)->data[i];
+ if (c == '\n' && print_escape_newlines)
+ {
+ PRINTCHAR ('\\');
+ PRINTCHAR ('n');
+ }
+ else if (c == '\f' && print_escape_newlines)
+ {
+ PRINTCHAR ('\\');
+ PRINTCHAR ('f');
+ }
+ else
+ {
+ if (c == '\"' || c == '\\')
+ PRINTCHAR ('\\');
+ PRINTCHAR (c);
+ }
+ }
+ PRINTCHAR ('\"');
+
+ UNGCPRO;
+ }
+ else if (SUBRP (obj))
+ {
+ strout ("#<subr ", -1, printcharfun);
+ strout (XSUBR (obj)->symbol_name, -1, printcharfun);
+ PRINTCHAR ('>');
+ }
#ifndef standalone
- case Lisp_Buffer:
- if (NILP (XBUFFER (obj)->name))
- strout ("#<killed buffer>", -1, printcharfun);
- else if (escapeflag)
+ else if (WINDOWP (obj))
{
- strout ("#<buffer ", -1, printcharfun);
- print_string (XBUFFER (obj)->name, printcharfun);
+ strout ("#<window ", -1, printcharfun);
+ sprintf (buf, "%d", XFASTINT (XWINDOW (obj)->sequence_number));
+ strout (buf, -1, printcharfun);
+ if (!NILP (XWINDOW (obj)->buffer))
+ {
+ strout (" on ", -1, printcharfun);
+ print_string (XBUFFER (XWINDOW (obj)->buffer)->name, printcharfun);
+ }
PRINTCHAR ('>');
}
- else
- print_string (XBUFFER (obj)->name, printcharfun);
- break;
-
- case Lisp_Process:
- if (escapeflag)
+ else if (BUFFERP (obj))
{
- strout ("#<process ", -1, printcharfun);
- print_string (XPROCESS (obj)->name, printcharfun);
+ if (NILP (XBUFFER (obj)->name))
+ strout ("#<killed buffer>", -1, printcharfun);
+ else if (escapeflag)
+ {
+ strout ("#<buffer ", -1, printcharfun);
+ print_string (XBUFFER (obj)->name, printcharfun);
+ PRINTCHAR ('>');
+ }
+ else
+ print_string (XBUFFER (obj)->name, printcharfun);
+ }
+ else if (WINDOW_CONFIGURATIONP (obj))
+ {
+ strout ("#<window-configuration>", -1, printcharfun);
+ }
+#ifdef MULTI_FRAME
+ else if (FRAMEP (obj))
+ {
+ strout ((FRAME_LIVE_P (XFRAME (obj))
+ ? "#<frame " : "#<dead frame "),
+ -1, printcharfun);
+ print_string (XFRAME (obj)->name, printcharfun);
+ sprintf (buf, " 0x%lx", (unsigned long) (XFRAME (obj)));
+ strout (buf, -1, printcharfun);
PRINTCHAR ('>');
}
+#endif
+#endif /* not standalone */
else
- print_string (XPROCESS (obj)->name, printcharfun);
- break;
-
- case Lisp_Window:
- strout ("#<window ", -1, printcharfun);
- sprintf (buf, "%d", XFASTINT (XWINDOW (obj)->sequence_number));
- strout (buf, -1, printcharfun);
- if (!NILP (XWINDOW (obj)->buffer))
{
- strout (" on ", -1, printcharfun);
- print_string (XBUFFER (XWINDOW (obj)->buffer)->name, printcharfun);
- }
- PRINTCHAR ('>');
- break;
+ int size = XVECTOR (obj)->size;
+ if (COMPILEDP (obj))
+ {
+ PRINTCHAR ('#');
+ size &= PSEUDOVECTOR_SIZE_MASK;
+ }
+ if (CHAR_TABLE_P (obj))
+ {
+ /* We print a char-table as if it were a vector,
+ lumping the parent and default slots in with the
+ character slots. But we add #^ as a prefix. */
+ PRINTCHAR ('#');
+ PRINTCHAR ('^');
+ size &= PSEUDOVECTOR_SIZE_MASK;
+ }
+ if (size & PSEUDOVECTOR_FLAG)
+ goto badtype;
- case Lisp_Window_Configuration:
- strout ("#<window-configuration>", -1, printcharfun);
- break;
+ PRINTCHAR ('[');
+ {
+ register int i;
+ register Lisp_Object tem;
-#ifdef MULTI_FRAME
- case Lisp_Frame:
- strout ((FRAME_LIVE_P (XFRAME (obj))
- ? "#<frame " : "#<dead frame "),
- -1, printcharfun);
- print_string (XFRAME (obj)->name, printcharfun);
- sprintf (buf, " 0x%x", (unsigned int) (XFRAME (obj)));
- strout (buf, -1, printcharfun);
- strout (">", -1, printcharfun);
- break;
-#endif /* MULTI_FRAME */
+ /* Don't print more elements than the specified maximum. */
+ if (INTEGERP (Vprint_length)
+ && XINT (Vprint_length) < size)
+ size = XINT (Vprint_length);
- case Lisp_Marker:
- strout ("#<marker ", -1, printcharfun);
- if (!(XMARKER (obj)->buffer))
- strout ("in no buffer", -1, printcharfun);
- else
- {
- sprintf (buf, "at %d", marker_position (obj));
- strout (buf, -1, printcharfun);
- strout (" in ", -1, printcharfun);
- print_string (XMARKER (obj)->buffer->name, printcharfun);
+ for (i = 0; i < size; i++)
+ {
+ if (i) PRINTCHAR (' ');
+ tem = XVECTOR (obj)->contents[i];
+ print (tem, printcharfun, escapeflag);
+ }
+ }
+ PRINTCHAR (']');
}
- PRINTCHAR ('>');
break;
- case Lisp_Overlay:
- strout ("#<overlay ", -1, printcharfun);
- if (!(XMARKER (OVERLAY_START (obj))->buffer))
- strout ("in no buffer", -1, printcharfun);
- else
+#ifndef standalone
+ case Lisp_Misc:
+ switch (XMISCTYPE (obj))
{
- sprintf (buf, "from %d to %d in ",
- marker_position (OVERLAY_START (obj)),
- marker_position (OVERLAY_END (obj)));
+ case Lisp_Misc_Marker:
+ strout ("#<marker ", -1, printcharfun);
+ if (!(XMARKER (obj)->buffer))
+ strout ("in no buffer", -1, printcharfun);
+ else
+ {
+ sprintf (buf, "at %d", marker_position (obj));
+ strout (buf, -1, printcharfun);
+ strout (" in ", -1, printcharfun);
+ print_string (XMARKER (obj)->buffer->name, printcharfun);
+ }
+ PRINTCHAR ('>');
+ break;
+
+ case Lisp_Misc_Overlay:
+ strout ("#<overlay ", -1, printcharfun);
+ if (!(XMARKER (OVERLAY_START (obj))->buffer))
+ strout ("in no buffer", -1, printcharfun);
+ else
+ {
+ sprintf (buf, "from %d to %d in ",
+ marker_position (OVERLAY_START (obj)),
+ marker_position (OVERLAY_END (obj)));
+ strout (buf, -1, printcharfun);
+ print_string (XMARKER (OVERLAY_START (obj))->buffer->name,
+ printcharfun);
+ }
+ PRINTCHAR ('>');
+ break;
+
+ /* 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, printcharfun);
+ break;
+
+ case Lisp_Misc_Intfwd:
+ sprintf (buf, "#<intfwd to %d>", *XINTFWD (obj)->intvar);
+ strout (buf, -1, printcharfun);
+ break;
+
+ case Lisp_Misc_Boolfwd:
+ sprintf (buf, "#<boolfwd to %s>",
+ (*XBOOLFWD (obj)->boolvar ? "t" : "nil"));
strout (buf, -1, printcharfun);
- print_string (XMARKER (OVERLAY_START (obj))->buffer->name,
- printcharfun);
+ break;
+
+ case Lisp_Misc_Objfwd:
+ strout (buf, "#<objfwd to ", -1, printcharfun);
+ print (*XOBJFWD (obj)->objvar, printcharfun, escapeflag);
+ PRINTCHAR ('>');
+ break;
+
+ case Lisp_Misc_Buffer_Objfwd:
+ strout (buf, "#<buffer_objfwd to ", -1, printcharfun);
+ print (*(Lisp_Object *)((char *)current_buffer
+ + XBUFFER_OBJFWD (obj)->offset),
+ printcharfun, escapeflag);
+ PRINTCHAR ('>');
+ break;
+
+ case Lisp_Misc_Kboard_Objfwd:
+ strout (buf, "#<kboard_objfwd to ", -1, printcharfun);
+ print (*(Lisp_Object *)((char *) current_kboard
+ + XKBOARD_OBJFWD (obj)->offset),
+ printcharfun, escapeflag);
+ PRINTCHAR ('>');
+ break;
+
+ case Lisp_Misc_Buffer_Local_Value:
+ strout ("#<buffer_local_value ", -1, printcharfun);
+ goto do_buffer_local;
+ case Lisp_Misc_Some_Buffer_Local_Value:
+ strout ("#<some_buffer_local_value ", -1, printcharfun);
+ do_buffer_local:
+ strout ("[realvalue] ", -1, printcharfun);
+ print (XBUFFER_LOCAL_VALUE (obj)->car, printcharfun, escapeflag);
+ strout ("[buffer] ", -1, printcharfun);
+ print (XCONS (XBUFFER_LOCAL_VALUE (obj)->cdr)->car,
+ printcharfun, escapeflag);
+ strout ("[alist-elt] ", -1, printcharfun);
+ print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj)->cdr)->cdr)->car,
+ printcharfun, escapeflag);
+ strout ("[default-value] ", -1, printcharfun);
+ print (XCONS (XCONS (XBUFFER_LOCAL_VALUE (obj)->cdr)->cdr)->cdr,
+ printcharfun, escapeflag);
+ PRINTCHAR ('>');
+ break;
+
+ default:
+ goto badtype;
}
- PRINTCHAR ('>');
break;
-
#endif /* standalone */
- case Lisp_Subr:
- strout ("#<subr ", -1, printcharfun);
- strout (XSUBR (obj)->symbol_name, -1, printcharfun);
- PRINTCHAR ('>');
- break;
+ default:
+ badtype:
+ {
+ /* We're in trouble if this happens!
+ Probably should just abort () */
+ strout ("#<EMACS BUG: INVALID DATATYPE ", -1, printcharfun);
+ if (MISCP (obj))
+ sprintf (buf, "(MISC 0x%04x)", (int) XMISCTYPE (obj));
+ else if (VECTORLIKEP (obj))
+ sprintf (buf, "(PVEC 0x%08x)", (int) XVECTOR (obj)->size);
+ else
+ sprintf (buf, "(0x%02x)", (int) XTYPE (obj));
+ strout (buf, -1, printcharfun);
+ strout (" Save your buffers immediately and please report this bug>",
+ -1, printcharfun);
+ }
}
print_depth--;
This may be any function of one argument.\n\
It may also be a buffer (output is inserted before point)\n\
or a marker (output is inserted and the marker is advanced)\n\
-or the symbol t (output appears in the minibuffer line).");
+or the symbol t (output appears in the echo area).");
Vstandard_output = Qt;
Qstandard_output = intern ("standard-output");
staticpro (&Qstandard_output);
Vprint_level = Qnil;
DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines,
- "Non-nil means print newlines in strings as backslash-n.
+ "Non-nil means print newlines in strings as backslash-n.\n\
Also print formfeeds as backslash-f.");
print_escape_newlines = 0;
defsubr (&Sprin1);
defsubr (&Sprin1_to_string);
+ defsubr (&Serror_message_string);
defsubr (&Sprinc);
defsubr (&Sprint);
defsubr (&Sterpri);
HCoop / bpt / emacs.git / blobdiff