/* Lisp object printing and output streams.
-Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2015 Free Software
+Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2016 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 3 of the License, or
-(at your option) any later version.
+the Free Software Foundation, either version 3 of the License, or (at
+your option) any later version.
GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
#include "lisp.h"
#include "character.h"
+#include "coding.h"
#include "buffer.h"
#include "charset.h"
-#include "keyboard.h"
#include "frame.h"
-#include "window.h"
#include "process.h"
-#include "dispextern.h"
-#include "termchar.h"
+#include "disptab.h"
#include "intervals.h"
#include "blockinput.h"
-#include "termhooks.h" /* For struct terminal. */
-#include "font.h"
-
-#ifdef HAVE_XWIDGETS
#include "xwidget.h"
-#endif
+#include <c-ctype.h>
#include <float.h>
#include <ftoastr.h>
+struct terminal;
+
/* Avoid actual stack overflow in print. */
static ptrdiff_t print_depth;
/* Lisp functions to do output using a stream
must have the stream in a variable called printcharfun
- and must start with PRINTPREPARE, end with PRINTFINISH,
- and use PRINTDECLARE to declare common variables.
- Use PRINTCHAR to output one character,
+ and must start with PRINTPREPARE, end with PRINTFINISH.
+ Use printchar to output one character,
or call strout to output a block of characters. */
-#define PRINTDECLARE \
+#define PRINTPREPARE \
struct buffer *old = current_buffer; \
ptrdiff_t old_point = -1, start_point = -1; \
ptrdiff_t old_point_byte = -1, start_point_byte = -1; \
bool free_print_buffer = 0; \
bool multibyte \
= !NILP (BVAR (current_buffer, enable_multibyte_characters)); \
- Lisp_Object original
-
-#define PRINTPREPARE \
- original = printcharfun; \
+ Lisp_Object original = printcharfun; \
if (NILP (printcharfun)) printcharfun = Qt; \
if (BUFFERP (printcharfun)) \
{ \
? PT_BYTE - start_point_byte : 0)); \
set_buffer_internal (old);
-#define PRINTCHAR(ch) printchar (ch, printcharfun)
-
/* This is used to restore the saved contents of print_buffer
when there is a recursive call to print. */
memcpy (print_buffer, SDATA (saved_text), SCHARS (saved_text));
}
+/* Print character CH to the stdio stream STREAM. */
+
+static void
+printchar_to_stream (unsigned int ch, FILE *stream)
+{
+ Lisp_Object dv IF_LINT (= Qnil);
+ ptrdiff_t i = 0, n = 1;
+ Lisp_Object coding_system = Vlocale_coding_system;
+ bool encode_p = false;
+
+ if (!NILP (Vcoding_system_for_write))
+ coding_system = Vcoding_system_for_write;
+ if (!NILP (coding_system))
+ encode_p = true;
+
+ if (CHAR_VALID_P (ch) && DISP_TABLE_P (Vstandard_display_table))
+ {
+ dv = DISP_CHAR_VECTOR (XCHAR_TABLE (Vstandard_display_table), ch);
+ if (VECTORP (dv))
+ {
+ n = ASIZE (dv);
+ goto next_char;
+ }
+ }
+
+ while (true)
+ {
+ if (ASCII_CHAR_P (ch))
+ {
+ putc (ch, stream);
+#ifdef WINDOWSNT
+ /* Send the output to a debugger (nothing happens if there
+ isn't one). */
+ if (print_output_debug_flag && stream == stderr)
+ OutputDebugString ((char []) {ch, '\0'});
+#endif
+ }
+ else
+ {
+ unsigned char mbstr[MAX_MULTIBYTE_LENGTH];
+ int len = CHAR_STRING (ch, mbstr);
+ Lisp_Object encoded_ch =
+ make_multibyte_string ((char *) mbstr, 1, len);
+
+ if (encode_p)
+ encoded_ch = code_convert_string_norecord (encoded_ch,
+ coding_system, true);
+ fwrite (SSDATA (encoded_ch), 1, SBYTES (encoded_ch), stream);
+#ifdef WINDOWSNT
+ if (print_output_debug_flag && stream == stderr)
+ OutputDebugString (SSDATA (encoded_ch));
+#endif
+ }
+
+ i++;
+
+ next_char:
+ for (; i < n; i++)
+ if (CHARACTERP (AREF (dv, i)))
+ break;
+ if (! (i < n))
+ break;
+ ch = XFASTINT (AREF (dv, i));
+ }
+}
/* Print character CH using method FUN. FUN nil means print to
print_buffer. FUN t means print to echo area or stdout if
else if (noninteractive)
{
printchar_stdout_last = ch;
- fwrite (str, 1, len, stdout);
+ if (DISP_TABLE_P (Vstandard_display_table))
+ printchar_to_stream (ch, stdout);
+ else
+ fwrite (str, 1, len, stdout);
noninteractive_need_newline = 1;
}
else
/* Output SIZE characters, SIZE_BYTE bytes from string PTR using
- method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for
- both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to
+ method PRINTCHARFUN. PRINTCHARFUN nil means output to
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
strout (const char *ptr, ptrdiff_t size, ptrdiff_t size_byte,
Lisp_Object printcharfun)
{
- if (size < 0)
- size_byte = size = strlen (ptr);
-
if (NILP (printcharfun))
{
ptrdiff_t incr = size_byte - (print_buffer_size - print_buffer_pos_byte);
}
else if (noninteractive && EQ (printcharfun, Qt))
{
- fwrite (ptr, 1, size_byte, stdout);
+ if (DISP_TABLE_P (Vstandard_display_table))
+ {
+ int len;
+ for (ptrdiff_t i = 0; i < size_byte; i += len)
+ {
+ int ch = STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr + i,
+ len);
+ printchar_to_stream (ch, stdout);
+ }
+ }
+ else
+ fwrite (ptr, 1, size_byte, stdout);
+
noninteractive_need_newline = 1;
}
else if (EQ (printcharfun, Qt))
while (i < size_byte)
{
int ch = ptr[i++];
- PRINTCHAR (ch);
+ printchar (ch, printcharfun);
}
}
else
int len;
int ch = STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr + i,
len);
- PRINTCHAR (ch);
+ printchar (ch, printcharfun);
i += len;
}
}
ptrdiff_t i;
ptrdiff_t size = SCHARS (string);
ptrdiff_t size_byte = SBYTES (string);
- struct gcpro gcpro1;
- GCPRO1 (string);
if (size == size_byte)
for (i = 0; i < size; i++)
- PRINTCHAR (SREF (string, i));
+ printchar (SREF (string, i), printcharfun);
else
for (i = 0; i < size_byte; )
{
corresponding character code before handing it to PRINTCHAR. */
int len;
int ch = STRING_CHAR_AND_LENGTH (SDATA (string) + i, len);
- PRINTCHAR (ch);
+ printchar (ch, printcharfun);
i += len;
}
- UNGCPRO;
}
}
\f
PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
(Lisp_Object character, Lisp_Object printcharfun)
{
- PRINTDECLARE;
-
if (NILP (printcharfun))
printcharfun = Vstandard_output;
CHECK_NUMBER (character);
PRINTPREPARE;
- PRINTCHAR (XINT (character));
+ printchar (XINT (character), printcharfun);
PRINTFINISH;
return character;
}
-/* Used from outside of print.c to print a block of SIZE
- single-byte chars at DATA on the default output stream.
+/* Print the contents of a unibyte C string STRING using PRINTCHARFUN.
+ The caller should arrange to put this inside PRINTPREPARE and PRINTFINISH.
Do not use this on the contents of a Lisp string. */
-void
-write_string (const char *data, int size)
+static void
+print_c_string (char const *string, Lisp_Object printcharfun)
{
- PRINTDECLARE;
- Lisp_Object printcharfun;
+ ptrdiff_t len = strlen (string);
+ strout (string, len, len, printcharfun);
+}
- printcharfun = Vstandard_output;
+/* Print unibyte C string at DATA on a specified stream PRINTCHARFUN.
+ Do not use this on the contents of a Lisp string. */
+static void
+write_string_1 (const char *data, Lisp_Object printcharfun)
+{
PRINTPREPARE;
- strout (data, size, size, printcharfun);
+ print_c_string (data, printcharfun);
PRINTFINISH;
}
-/* Used to print a block of SIZE single-byte chars at DATA on a
- specified stream PRINTCHARFUN.
+/* Used from outside of print.c to print a C unibyte
+ string at DATA on the default output stream.
Do not use this on the contents of a Lisp string. */
-static void
-write_string_1 (const char *data, int size, Lisp_Object printcharfun)
+void
+write_string (const char *data)
{
- PRINTDECLARE;
-
- PRINTPREPARE;
- strout (data, size, size, printcharfun);
- PRINTFINISH;
+ write_string_1 (data, Vstandard_output);
}
If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */)
(Lisp_Object printcharfun, Lisp_Object ensure)
{
- Lisp_Object val = Qnil;
+ Lisp_Object val;
- PRINTDECLARE;
if (NILP (printcharfun))
printcharfun = Vstandard_output;
PRINTPREPARE;
signal_error ("Unsupported function argument", printcharfun);
else if (noninteractive && !NILP (printcharfun))
val = printchar_stdout_last == 10 ? Qnil : Qt;
- else if (NILP (Fbolp ()))
- val = Qt;
+ else
+ val = NILP (Fbolp ()) ? Qt : Qnil;
- if (!NILP (val)) PRINTCHAR ('\n');
+ if (!NILP (val))
+ printchar ('\n', printcharfun);
PRINTFINISH;
return val;
}
is used instead. */)
(Lisp_Object object, Lisp_Object printcharfun)
{
- PRINTDECLARE;
-
if (NILP (printcharfun))
printcharfun = Vstandard_output;
PRINTPREPARE;
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;
- Lisp_Object save_deactivate_mark;
ptrdiff_t count = SPECPDL_INDEX ();
- struct buffer *previous;
specbind (Qinhibit_modification_hooks, Qt);
- {
- PRINTDECLARE;
-
- /* 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. */
- save_deactivate_mark = Vdeactivate_mark;
- prev_abort_on_gc = abort_on_gc;
- abort_on_gc = 1;
-
- printcharfun = Vprin1_to_string_buffer;
- PRINTPREPARE;
- print (object, printcharfun, NILP (noescape));
- /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINISH */
- PRINTFINISH;
- }
+ /* 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. */
+ Lisp_Object save_deactivate_mark = Vdeactivate_mark;
+ bool prev_abort_on_gc = abort_on_gc;
+ abort_on_gc = true;
+
+ Lisp_Object printcharfun = Vprin1_to_string_buffer;
+ PRINTPREPARE;
+ print (object, printcharfun, NILP (noescape));
+ /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINISH */
+ PRINTFINISH;
- previous = current_buffer;
+ struct buffer *previous = current_buffer;
set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
object = Fbuffer_string ();
if (SBYTES (object) == SCHARS (object))
is used instead. */)
(Lisp_Object object, Lisp_Object printcharfun)
{
- PRINTDECLARE;
-
if (NILP (printcharfun))
printcharfun = Vstandard_output;
PRINTPREPARE;
is used instead. */)
(Lisp_Object object, Lisp_Object printcharfun)
{
- PRINTDECLARE;
- struct gcpro gcpro1;
-
if (NILP (printcharfun))
printcharfun = Vstandard_output;
- GCPRO1 (object);
PRINTPREPARE;
- PRINTCHAR ('\n');
+ printchar ('\n', printcharfun);
print (object, printcharfun, 1);
- PRINTCHAR ('\n');
+ printchar ('\n', printcharfun);
PRINTFINISH;
- UNGCPRO;
return object;
}
to make it write to the debugging output. */)
(Lisp_Object character)
{
- unsigned int ch;
-
CHECK_NUMBER (character);
- ch = XINT (character);
- if (ASCII_CHAR_P (ch))
- {
- putc (ch, stderr);
-#ifdef WINDOWSNT
- /* Send the output to a debugger (nothing happens if there isn't
- one). */
- if (print_output_debug_flag)
- {
- char buf[2] = {(char) XINT (character), '\0'};
- OutputDebugString (buf);
- }
-#endif
- }
- else
- {
- unsigned char mbstr[MAX_MULTIBYTE_LENGTH];
- ptrdiff_t len = CHAR_STRING (ch, mbstr);
- Lisp_Object encoded_ch =
- ENCODE_SYSTEM (make_multibyte_string ((char *) mbstr, 1, len));
-
- fwrite (SSDATA (encoded_ch), SBYTES (encoded_ch), 1, stderr);
-#ifdef WINDOWSNT
- if (print_output_debug_flag)
- OutputDebugString (SSDATA (encoded_ch));
-#endif
- }
-
+ printchar_to_stream (XINT (character), stderr);
return character;
}
if (valid > 0)
debug_print (arg);
else
- fprintf (stderr, "#<%s_LISP_OBJECT 0x%08"pI"x>\r\n",
- !valid ? "INVALID" : "SOME",
- XLI (arg));
+ {
+ EMACS_UINT n = XLI (arg);
+ fprintf (stderr, "#<%s_LISP_OBJECT 0x%08"pI"x>\r\n",
+ !valid ? "INVALID" : "SOME",
+ n);
+ }
}
\f
{
struct buffer *old = current_buffer;
Lisp_Object value;
- struct gcpro gcpro1;
/* If OBJ is (error STRING), just return STRING.
That is not only faster, it also avoids the need to allocate
set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
value = Fbuffer_string ();
- GCPRO1 (value);
Ferase_buffer ();
set_buffer_internal (old);
- UNGCPRO;
return value;
}
Lisp_Object caller)
{
Lisp_Object errname, errmsg, file_error, tail;
- struct gcpro gcpro1;
if (context != 0)
- write_string_1 (context, -1, stream);
+ write_string_1 (context, stream);
/* If we know from where the error was signaled, show it in
*Messages*. */
USE_SAFE_ALLOCA;
char *name = SAFE_ALLOCA (cnamelen);
memcpy (name, SDATA (cname), cnamelen);
- message_dolog (name, cnamelen, 0, 0);
+ message_dolog (name, cnamelen, 0, STRING_MULTIBYTE (cname));
message_dolog (": ", 2, 0, 0);
SAFE_FREE ();
}
/* 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. */
const char *sep = ": ";
if (!STRINGP (errmsg))
- write_string_1 ("peculiar error", -1, stream);
+ write_string_1 ("peculiar error", stream);
else if (SCHARS (errmsg))
- Fprinc (errmsg, stream);
+ Fprinc (Fsubstitute_command_keys (errmsg), stream);
else
sep = NULL;
Lisp_Object obj;
if (sep)
- write_string_1 (sep, 2, stream);
+ write_string_1 (sep, stream);
obj = XCAR (tail);
if (!NILP (file_error)
|| EQ (errname, Qend_of_file) || EQ (errname, Quser_error))
Fprin1 (obj, stream);
}
}
-
- UNGCPRO;
}
print_string (obj, printcharfun);
else
{
- register ptrdiff_t i, i_byte;
- struct gcpro gcpro1;
+ ptrdiff_t i, i_byte;
ptrdiff_t size_byte;
- /* 1 means we must ensure that the next character we output
+ /* True means we must ensure that the next character we output
cannot be taken as part of a hex character escape. */
- bool need_nonhex = 0;
+ bool need_nonhex = false;
bool multibyte = STRING_MULTIBYTE (obj);
- GCPRO1 (obj);
-
if (! EQ (Vprint_charset_text_property, Qt))
obj = print_prune_string_charset (obj);
if (string_intervals (obj))
- {
- PRINTCHAR ('#');
- PRINTCHAR ('(');
- }
+ print_c_string ("#(", printcharfun);
- PRINTCHAR ('\"');
+ printchar ('\"', printcharfun);
size_byte = SBYTES (obj);
for (i = 0, i_byte = 0; i_byte < size_byte;)
{
/* Here, we must convert each multi-byte form to the
- corresponding character code before handing it to PRINTCHAR. */
+ corresponding character code before handing it to printchar. */
int c;
FETCH_STRING_CHAR_ADVANCE (c, obj, i, i_byte);
QUIT;
- if (c == '\n' && print_escape_newlines)
- {
- PRINTCHAR ('\\');
- PRINTCHAR ('n');
- }
- else if (c == '\f' && print_escape_newlines)
+ if (multibyte
+ ? (CHAR_BYTE8_P (c) && (c = CHAR_TO_BYTE8 (c), true))
+ : (SINGLE_BYTE_CHAR_P (c) && ! ASCII_CHAR_P (c)
+ && print_escape_nonascii))
{
- PRINTCHAR ('\\');
- PRINTCHAR ('f');
- }
- else if (multibyte
- && (CHAR_BYTE8_P (c)
- || (! ASCII_CHAR_P (c) && print_escape_multibyte)))
- {
- /* When multibyte is disabled,
- print multibyte string chars using hex escapes.
- For a char code that could be in a unibyte string,
- when found in a multibyte string, always use a hex escape
- so it reads back as multibyte. */
- char outbuf[50];
- int len;
-
- if (CHAR_BYTE8_P (c))
- len = sprintf (outbuf, "\\%03o", CHAR_TO_BYTE8 (c));
- else
- {
- len = sprintf (outbuf, "\\x%04x", c);
- need_nonhex = 1;
- }
- strout (outbuf, len, len, printcharfun);
- }
- else if (! multibyte
- && SINGLE_BYTE_CHAR_P (c) && ! ASCII_CHAR_P (c)
- && print_escape_nonascii)
- {
- /* When printing in a multibyte buffer
- or when explicitly requested,
+ /* When printing a raw 8-bit byte in a multibyte buffer, or
+ (when requested) a non-ASCII character in a unibyte buffer,
print single-byte non-ASCII string chars
using octal escapes. */
char outbuf[5];
- int len = sprintf (outbuf, "\\%03o", c);
+ int len = sprintf (outbuf, "\\%03o", c + 0u);
+ strout (outbuf, len, len, printcharfun);
+ need_nonhex = false;
+ }
+ else if (multibyte
+ && ! ASCII_CHAR_P (c) && print_escape_multibyte)
+ {
+ /* When requested, print multibyte chars using hex escapes. */
+ char outbuf[sizeof "\\x" + INT_STRLEN_BOUND (c)];
+ int len = sprintf (outbuf, "\\x%04x", c + 0u);
strout (outbuf, len, len, printcharfun);
+ need_nonhex = true;
}
else
{
/* If we just had a hex escape, and this character
could be taken as part of it,
output `\ ' to prevent that. */
- if (need_nonhex)
- {
- need_nonhex = 0;
- if ((c >= 'a' && c <= 'f')
- || (c >= 'A' && c <= 'F')
- || (c >= '0' && c <= '9'))
- strout ("\\ ", -1, -1, printcharfun);
- }
-
- if (c == '\"' || c == '\\')
- PRINTCHAR ('\\');
- PRINTCHAR (c);
+ if (need_nonhex && c_isxdigit (c))
+ print_c_string ("\\ ", printcharfun);
+
+ if (c == '\n' && print_escape_newlines
+ ? (c = 'n', true)
+ : c == '\f' && print_escape_newlines
+ ? (c = 'f', true)
+ : c == '\"' || c == '\\')
+ printchar ('\\', printcharfun);
+
+ printchar (c, printcharfun);
+ need_nonhex = false;
}
}
- PRINTCHAR ('\"');
+ printchar ('\"', printcharfun);
if (string_intervals (obj))
{
traverse_intervals (string_intervals (obj),
0, print_interval, printcharfun);
- PRINTCHAR (')');
+ printchar (')', printcharfun);
}
-
- UNGCPRO;
}
break;
size_byte = SBYTES (name);
if (! NILP (Vprint_gensym) && !SYMBOL_INTERNED_P (obj))
- {
- PRINTCHAR ('#');
- PRINTCHAR (':');
- }
+ print_c_string ("#:", printcharfun);
else if (size_byte == 0)
{
- PRINTCHAR ('#');
- PRINTCHAR ('#');
+ print_c_string ("##", printcharfun);
break;
}
|| c == ',' || c == '.' || c == '`'
|| c == '[' || c == ']' || c == '?' || c <= 040
|| confusing)
- PRINTCHAR ('\\'), confusing = 0;
+ {
+ printchar ('\\', printcharfun);
+ confusing = false;
+ }
}
- PRINTCHAR (c);
+ printchar (c, printcharfun);
}
}
break;
/* If deeper than spec'd depth, print placeholder. */
if (INTEGERP (Vprint_level)
&& print_depth > XINT (Vprint_level))
- strout ("...", -1, -1, printcharfun);
+ print_c_string ("...", printcharfun);
else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
- && (EQ (XCAR (obj), Qquote)))
+ && EQ (XCAR (obj), Qquote))
{
- PRINTCHAR ('\'');
+ printchar ('\'', printcharfun);
print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
}
else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
- && (EQ (XCAR (obj), Qfunction)))
+ && EQ (XCAR (obj), Qfunction))
{
- PRINTCHAR ('#');
- PRINTCHAR ('\'');
+ print_c_string ("#'", printcharfun);
print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
}
else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
- && ((EQ (XCAR (obj), Qbackquote))))
+ && EQ (XCAR (obj), Qbackquote))
{
- print_object (XCAR (obj), printcharfun, 0);
+ printchar ('`', printcharfun);
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))))
+ && (EQ (XCAR (obj), Qcomma)
+ || EQ (XCAR (obj), Qcomma_at)
+ || EQ (XCAR (obj), Qcomma_dot)))
{
- print_object (XCAR (obj), printcharfun, 0);
+ print_object (XCAR (obj), printcharfun, false);
new_backquote_output--;
print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
new_backquote_output++;
}
else
{
- PRINTCHAR ('(');
+ printchar ('(', printcharfun);
- {
- printmax_t i, print_length;
- Lisp_Object halftail = obj;
+ Lisp_Object halftail = obj;
- /* Negative values of print-length are invalid in CL.
- Treat them like nil, as CMUCL does. */
- if (NATNUMP (Vprint_length))
- print_length = XFASTINT (Vprint_length);
- else
- print_length = TYPE_MAXIMUM (printmax_t);
+ /* Negative values of print-length are invalid in CL.
+ Treat them like nil, as CMUCL does. */
+ printmax_t print_length = (NATNUMP (Vprint_length)
+ ? XFASTINT (Vprint_length)
+ : TYPE_MAXIMUM (printmax_t));
- i = 0;
- while (CONSP (obj))
- {
- /* Detect circular list. */
- if (NILP (Vprint_circle))
- {
- /* Simple but incomplete way. */
- if (i != 0 && EQ (obj, halftail))
- {
- int len = sprintf (buf, " . #%"pMd, i / 2);
- strout (buf, len, len, printcharfun);
- goto end_of_list;
- }
- }
- else
- {
- /* With the print-circle feature. */
- if (i != 0)
- {
- Lisp_Object num = Fgethash (obj, Vprint_number_table, Qnil);
- if (INTEGERP (num))
- {
- strout (" . ", 3, 3, printcharfun);
- print_object (obj, printcharfun, escapeflag);
- goto end_of_list;
- }
- }
- }
+ printmax_t i = 0;
+ while (CONSP (obj))
+ {
+ /* Detect circular list. */
+ if (NILP (Vprint_circle))
+ {
+ /* Simple but incomplete way. */
+ if (i != 0 && EQ (obj, halftail))
+ {
+ int len = sprintf (buf, " . #%"pMd, i / 2);
+ strout (buf, len, len, printcharfun);
+ goto end_of_list;
+ }
+ }
+ else
+ {
+ /* With the print-circle feature. */
+ if (i != 0)
+ {
+ Lisp_Object num = Fgethash (obj, Vprint_number_table, Qnil);
+ if (INTEGERP (num))
+ {
+ print_c_string (" . ", printcharfun);
+ print_object (obj, printcharfun, escapeflag);
+ goto end_of_list;
+ }
+ }
+ }
- if (i)
- PRINTCHAR (' ');
+ if (i)
+ printchar (' ', printcharfun);
- if (print_length <= i)
- {
- strout ("...", 3, 3, printcharfun);
- goto end_of_list;
- }
+ if (print_length <= i)
+ {
+ print_c_string ("...", printcharfun);
+ goto end_of_list;
+ }
- i++;
- print_object (XCAR (obj), printcharfun, escapeflag);
+ i++;
+ print_object (XCAR (obj), printcharfun, escapeflag);
- obj = XCDR (obj);
- if (!(i & 1))
- halftail = XCDR (halftail);
- }
+ obj = XCDR (obj);
+ if (!(i & 1))
+ halftail = XCDR (halftail);
}
/* OBJ non-nil here means it's the end of a dotted list. */
if (!NILP (obj))
{
- strout (" . ", 3, 3, printcharfun);
+ print_c_string (" . ", printcharfun);
print_object (obj, printcharfun, escapeflag);
}
end_of_list:
- PRINTCHAR (')');
+ printchar (')', printcharfun);
}
break;
{
if (escapeflag)
{
- strout ("#<process ", -1, -1, printcharfun);
+ print_c_string ("#<process ", printcharfun);
print_string (XPROCESS (obj)->name, printcharfun);
- PRINTCHAR ('>');
+ printchar ('>', printcharfun);
}
else
print_string (XPROCESS (obj)->name, printcharfun);
else if (BOOL_VECTOR_P (obj))
{
ptrdiff_t i;
- int len;
unsigned char c;
- struct gcpro gcpro1;
EMACS_INT size = bool_vector_size (obj);
ptrdiff_t size_in_chars = bool_vector_bytes (size);
ptrdiff_t real_size_in_chars = size_in_chars;
- GCPRO1 (obj);
- PRINTCHAR ('#');
- PRINTCHAR ('&');
- len = sprintf (buf, "%"pI"d", size);
+ int len = sprintf (buf, "#&%"pI"d\"", size);
strout (buf, len, len, printcharfun);
- PRINTCHAR ('\"');
/* Don't print more characters than the specified maximum.
Negative values of print-length are invalid. Treat them
QUIT;
c = bool_vector_uchar_data (obj)[i];
if (c == '\n' && print_escape_newlines)
- {
- PRINTCHAR ('\\');
- PRINTCHAR ('n');
- }
+ print_c_string ("\\n", printcharfun);
else if (c == '\f' && print_escape_newlines)
- {
- PRINTCHAR ('\\');
- PRINTCHAR ('f');
- }
+ print_c_string ("\\f", printcharfun);
else if (c > '\177')
{
/* Use octal escapes to avoid encoding issues. */
- PRINTCHAR ('\\');
- PRINTCHAR ('0' + ((c >> 6) & 3));
- PRINTCHAR ('0' + ((c >> 3) & 7));
- PRINTCHAR ('0' + (c & 7));
+ len = sprintf (buf, "\\%o", c);
+ strout (buf, len, len, printcharfun);
}
else
{
if (c == '\"' || c == '\\')
- PRINTCHAR ('\\');
- PRINTCHAR (c);
+ printchar ('\\', printcharfun);
+ printchar (c, printcharfun);
}
}
if (size_in_chars < real_size_in_chars)
- strout (" ...", 4, 4, printcharfun);
- PRINTCHAR ('\"');
-
- UNGCPRO;
+ print_c_string (" ...", printcharfun);
+ printchar ('\"', printcharfun);
}
else if (SUBRP (obj))
{
- strout ("#<subr ", -1, -1, printcharfun);
- strout (XSUBR (obj)->symbol_name, -1, -1, printcharfun);
- PRINTCHAR ('>');
+ print_c_string ("#<subr ", printcharfun);
+ print_c_string (XSUBR (obj)->symbol_name, printcharfun);
+ printchar ('>', printcharfun);
}
-#ifdef HAVE_XWIDGETS
- else if (XWIDGETP (obj))
+ else if (XWIDGETP (obj) || XWIDGET_VIEW_P (obj))
{
- strout ("#<xwidget ", -1, -1, printcharfun);
- PRINTCHAR ('>');
+ print_c_string ("#<xwidget ", printcharfun);
+ printchar ('>', printcharfun);
}
- else if (XWIDGET_VIEW_P (obj))
- {
- strout ("#<xwidget-view ", -1, -1, printcharfun);
- PRINTCHAR ('>');
- }
-#endif
else if (WINDOWP (obj))
{
- int len;
- strout ("#<window ", -1, -1, printcharfun);
- len = sprintf (buf, "%d", XWINDOW (obj)->sequence_number);
+ int len = sprintf (buf, "#<window %"pI"d",
+ XWINDOW (obj)->sequence_number);
strout (buf, len, len, printcharfun);
if (BUFFERP (XWINDOW (obj)->contents))
{
- strout (" on ", -1, -1, printcharfun);
+ print_c_string (" on ", printcharfun);
print_string (BVAR (XBUFFER (XWINDOW (obj)->contents), name),
printcharfun);
}
- PRINTCHAR ('>');
+ printchar ('>', printcharfun);
}
else if (TERMINALP (obj))
{
- int len;
struct terminal *t = XTERMINAL (obj);
- strout ("#<terminal ", -1, -1, printcharfun);
- len = sprintf (buf, "%d", t->id);
+ int len = sprintf (buf, "#<terminal %d", t->id);
strout (buf, len, len, printcharfun);
if (t->name)
{
- strout (" on ", -1, -1, printcharfun);
- strout (t->name, -1, -1, printcharfun);
+ print_c_string (" on ", printcharfun);
+ print_c_string (t->name, printcharfun);
}
- PRINTCHAR ('>');
+ printchar ('>', printcharfun);
}
else if (HASH_TABLE_P (obj))
{
int len;
#if 0
void *ptr = h;
- strout ("#<hash-table", -1, -1, printcharfun);
+ print_c_string ("#<hash-table", printcharfun);
if (SYMBOLP (h->test))
{
- PRINTCHAR (' ');
- PRINTCHAR ('\'');
- strout (SDATA (SYMBOL_NAME (h->test)), -1, -1, printcharfun);
- PRINTCHAR (' ');
- strout (SDATA (SYMBOL_NAME (h->weak)), -1, -1, printcharfun);
- PRINTCHAR (' ');
- len = sprintf (buf, "%"pD"d/%"pD"d", h->count, ASIZE (h->next));
+ print_c_string (" '", printcharfun);
+ print_c_string (SSDATA (SYMBOL_NAME (h->test)), printcharfun);
+ printchar (' ', printcharfun);
+ print_c_string (SSDATA (SYMBOL_NAME (h->weak)), printcharfun);
+ len = sprintf (buf, " %"pD"d/%"pD"d", h->count, ASIZE (h->next));
strout (buf, len, len, printcharfun);
}
len = sprintf (buf, " %p>", ptr);
if (!NILP (h->test.name))
{
- strout (" test ", -1, -1, printcharfun);
+ print_c_string (" test ", printcharfun);
print_object (h->test.name, printcharfun, escapeflag);
}
if (!NILP (h->weak))
{
- strout (" weakness ", -1, -1, printcharfun);
+ print_c_string (" weakness ", printcharfun);
print_object (h->weak, printcharfun, escapeflag);
}
if (!NILP (h->rehash_size))
{
- strout (" rehash-size ", -1, -1, printcharfun);
+ print_c_string (" rehash-size ", printcharfun);
print_object (h->rehash_size, printcharfun, escapeflag);
}
if (!NILP (h->rehash_threshold))
{
- strout (" rehash-threshold ", -1, -1, printcharfun);
+ print_c_string (" rehash-threshold ", printcharfun);
print_object (h->rehash_threshold, printcharfun, escapeflag);
}
- strout (" data ", -1, -1, printcharfun);
+ print_c_string (" data ", printcharfun);
/* Print the data here as a plist. */
real_size = HASH_TABLE_SIZE (h);
&& XFASTINT (Vprint_length) < size)
size = XFASTINT (Vprint_length);
- PRINTCHAR ('(');
+ printchar ('(', printcharfun);
for (i = 0; i < size; i++)
if (!NILP (HASH_HASH (h, i)))
{
- if (i) PRINTCHAR (' ');
+ if (i) printchar (' ', printcharfun);
print_object (HASH_KEY (h, i), printcharfun, escapeflag);
- PRINTCHAR (' ');
+ printchar (' ', printcharfun);
print_object (HASH_VALUE (h, i), printcharfun, escapeflag);
}
if (size < real_size)
- strout (" ...", 4, 4, printcharfun);
+ print_c_string (" ...", printcharfun);
- PRINTCHAR (')');
- PRINTCHAR (')');
+ print_c_string ("))", printcharfun);
}
else if (BUFFERP (obj))
{
if (!BUFFER_LIVE_P (XBUFFER (obj)))
- strout ("#<killed buffer>", -1, -1, printcharfun);
+ print_c_string ("#<killed buffer>", printcharfun);
else if (escapeflag)
{
- strout ("#<buffer ", -1, -1, printcharfun);
+ print_c_string ("#<buffer ", printcharfun);
print_string (BVAR (XBUFFER (obj), name), printcharfun);
- PRINTCHAR ('>');
+ printchar ('>', printcharfun);
}
else
print_string (BVAR (XBUFFER (obj), name), printcharfun);
}
else if (WINDOW_CONFIGURATIONP (obj))
- {
- strout ("#<window-configuration>", -1, -1, printcharfun);
- }
+ print_c_string ("#<window-configuration>", printcharfun);
else if (FRAMEP (obj))
{
int len;
void *ptr = XFRAME (obj);
Lisp_Object frame_name = XFRAME (obj)->name;
- strout ((FRAME_LIVE_P (XFRAME (obj))
- ? "#<frame " : "#<dead frame "),
- -1, -1, printcharfun);
+ print_c_string ((FRAME_LIVE_P (XFRAME (obj))
+ ? "#<frame "
+ : "#<dead frame "),
+ printcharfun);
if (!STRINGP (frame_name))
{
/* A frame could be too young and have no name yet;
if (! FONT_OBJECT_P (obj))
{
if (FONT_SPEC_P (obj))
- strout ("#<font-spec", -1, -1, printcharfun);
+ print_c_string ("#<font-spec", printcharfun);
else
- strout ("#<font-entity", -1, -1, printcharfun);
+ print_c_string ("#<font-entity", printcharfun);
for (i = 0; i < FONT_SPEC_MAX; i++)
{
- PRINTCHAR (' ');
+ printchar (' ', printcharfun);
if (i < FONT_WEIGHT_INDEX || i > FONT_WIDTH_INDEX)
print_object (AREF (obj, i), printcharfun, escapeflag);
else
}
else
{
- strout ("#<font-object ", -1, -1, printcharfun);
+ print_c_string ("#<font-object ", printcharfun);
print_object (AREF (obj, FONT_NAME_INDEX), printcharfun,
escapeflag);
}
- PRINTCHAR ('>');
+ printchar ('>', printcharfun);
}
else
{
ptrdiff_t size = ASIZE (obj);
if (COMPILEDP (obj))
{
- PRINTCHAR ('#');
+ printchar ('#', printcharfun);
size &= PSEUDOVECTOR_SIZE_MASK;
}
if (CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj))
results in slow redisplay. */
if (SUB_CHAR_TABLE_P (obj)
&& XSUB_CHAR_TABLE (obj)->depth == 3)
- PRINTCHAR ('\n');
- PRINTCHAR ('#');
- PRINTCHAR ('^');
+ printchar ('\n', printcharfun);
+ print_c_string ("#^", printcharfun);
if (SUB_CHAR_TABLE_P (obj))
- PRINTCHAR ('^');
+ printchar ('^', printcharfun);
size &= PSEUDOVECTOR_SIZE_MASK;
}
if (size & PSEUDOVECTOR_FLAG)
goto badtype;
- PRINTCHAR ('[');
+ printchar ('[', printcharfun);
{
int i, idx = SUB_CHAR_TABLE_P (obj) ? SUB_CHAR_TABLE_OFFSET : 0;
- register Lisp_Object tem;
+ Lisp_Object tem;
ptrdiff_t real_size = size;
/* For a sub char-table, print heading non-Lisp data first. */
for (i = idx; i < size; i++)
{
- if (i) PRINTCHAR (' ');
+ if (i) printchar (' ', printcharfun);
tem = AREF (obj, i);
print_object (tem, printcharfun, escapeflag);
}
if (size < real_size)
- strout (" ...", 4, 4, printcharfun);
+ print_c_string (" ...", printcharfun);
}
- PRINTCHAR (']');
+ printchar (']', printcharfun);
}
break;
switch (XMISCTYPE (obj))
{
case Lisp_Misc_Marker:
- strout ("#<marker ", -1, -1, printcharfun);
+ print_c_string ("#<marker ", printcharfun);
/* Do you think this is necessary? */
if (XMARKER (obj)->insertion_type != 0)
- strout ("(moves after insertion) ", -1, -1, printcharfun);
+ print_c_string ("(moves after insertion) ", printcharfun);
if (! XMARKER (obj)->buffer)
- strout ("in no buffer", -1, -1, printcharfun);
+ print_c_string ("in no buffer", printcharfun);
else
{
- int len = sprintf (buf, "at %"pD"d", marker_position (obj));
+ int len = sprintf (buf, "at %"pD"d in ", marker_position (obj));
strout (buf, len, len, printcharfun);
- strout (" in ", -1, -1, printcharfun);
print_string (BVAR (XMARKER (obj)->buffer, name), printcharfun);
}
- PRINTCHAR ('>');
+ printchar ('>', printcharfun);
break;
case Lisp_Misc_Overlay:
- strout ("#<overlay ", -1, -1, printcharfun);
+ print_c_string ("#<overlay ", printcharfun);
if (! XMARKER (OVERLAY_START (obj))->buffer)
- strout ("in no buffer", -1, -1, printcharfun);
+ print_c_string ("in no buffer", printcharfun);
else
{
int len = sprintf (buf, "from %"pD"d to %"pD"d in ",
print_string (BVAR (XMARKER (OVERLAY_START (obj))->buffer, name),
printcharfun);
}
- PRINTCHAR ('>');
- break;
+ printchar ('>', printcharfun);
+ break;
+
+#ifdef HAVE_MODULES
+ case Lisp_Misc_User_Ptr:
+ {
+ print_c_string ("#<user-ptr ", printcharfun);
+ int i = sprintf (buf, "ptr=%p finalizer=%p",
+ XUSER_PTR (obj)->p,
+ XUSER_PTR (obj)->finalizer);
+ strout (buf, i, i, printcharfun);
+ printchar ('>', printcharfun);
+ break;
+ }
+#endif
+
+ case Lisp_Misc_Finalizer:
+ print_c_string ("#<finalizer", printcharfun);
+ if (NILP (XFINALIZER (obj)->function))
+ print_c_string (" used", printcharfun);
+ printchar ('>', printcharfun);
+ 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, -1, printcharfun);
+ print_c_string ("#<misc free cell>", printcharfun);
break;
case Lisp_Misc_Save_Value:
int i;
struct Lisp_Save_Value *v = XSAVE_VALUE (obj);
- strout ("#<save-value ", -1, -1, printcharfun);
+ print_c_string ("#<save-value ", 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. */
Lisp_Object maybe = area[i];
int valid = valid_lisp_object_p (maybe);
+ printchar (' ', printcharfun);
if (0 < valid)
- {
- PRINTCHAR (' ');
- print_object (maybe, printcharfun, escapeflag);
- }
+ print_object (maybe, printcharfun, escapeflag);
else
- strout (valid ? " <some>" : " <invalid>",
- -1, -1, printcharfun);
+ print_c_string (valid < 0 ? "<some>" : "<invalid>",
+ 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 */
+ print_c_string (" ...", printcharfun);
}
else
{
for (index = 0; index < SAVE_VALUE_SLOTS; index++)
{
if (index)
- PRINTCHAR (' ');
+ printchar (' ', printcharfun);
switch (save_type (v, index))
{
strout (buf, i, i, printcharfun);
}
}
- PRINTCHAR ('>');
+ printchar ('>', printcharfun);
}
break;
int len;
/* We're in trouble if this happens!
Probably should just emacs_abort (). */
- strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun);
+ print_c_string ("#<EMACS BUG: INVALID DATATYPE ", printcharfun);
if (MISCP (obj))
- len = sprintf (buf, "(MISC 0x%04x)", (int) XMISCTYPE (obj));
+ len = sprintf (buf, "(MISC 0x%04x)", (unsigned) XMISCTYPE (obj));
else if (VECTORLIKEP (obj))
- len = sprintf (buf, "(PVEC 0x%08"pD"x)", ASIZE (obj));
+ len = sprintf (buf, "(PVEC 0x%08zx)", (size_t) ASIZE (obj));
else
- len = sprintf (buf, "(0x%02x)", (int) XTYPE (obj));
+ len = sprintf (buf, "(0x%02x)", (unsigned) XTYPE (obj));
strout (buf, len, len, printcharfun);
- strout (" Save your buffers immediately and please report this bug>",
- -1, -1, printcharfun);
+ print_c_string ((" Save your buffers immediately"
+ " and please report this bug>"),
+ printcharfun);
}
}
{
if (NILP (interval->plist))
return;
- PRINTCHAR (' ');
+ printchar (' ', printcharfun);
print_object (make_number (interval->position), printcharfun, 1);
- PRINTCHAR (' ');
+ printchar (' ', printcharfun);
print_object (make_number (interval->position + LENGTH (interval)),
printcharfun, 1);
- PRINTCHAR (' ');
+ printchar (' ', printcharfun);
print_object (interval->plist, printcharfun, 1);
}
A value of nil means to use the shortest notation
that represents the number without losing information. */);
Vfloat_output_format = Qnil;
- DEFSYM (Qfloat_output_format, "float-output-format");
DEFVAR_LISP ("print-length", Vprint_length,
doc: /* Maximum length of list to print before abbreviating.
DEFVAR_BOOL ("print-quoted", print_quoted,
doc: /* Non-nil means print quoted forms with reader syntax.
-I.e., (quote foo) prints as 'foo, (function foo) as #'foo. */);
+I.e., (quote foo) prints as \\='foo, (function foo) as #\\='foo. */);
print_quoted = 0;
DEFVAR_LISP ("print-gensym", Vprint_gensym,