/* Lisp object printing and output streams.
Copyright (C) 1985, 1986, 1988, 1992-1995 Free Software Foundation, Inc.
- Copyright (C) 1995, 1996 Ben Wing.
+ Copyright (C) 1995, 1996, 2000 Ben Wing.
This file is part of XEmacs.
#include "insdel.h"
#include "lstream.h"
#include "sysfile.h"
+#ifdef WINDOWSNT
+#include "console-msw.h"
+#endif
+#include <limits.h>
#include <float.h>
/* Define if not in float.h */
#ifndef DBL_DIG
/* The subroutine object for external-debugging-output is kept here
for the convenience of the debugger. */
Lisp_Object Qexternal_debugging_output;
-Lisp_Object Qalternate_debugging_output;
/* Avoid actual stack overflow in print. */
static int print_depth;
/* Detect most circularities to print finite output. */
#define PRINT_CIRCLE 200
-Lisp_Object being_printed[PRINT_CIRCLE];
+static Lisp_Object being_printed[PRINT_CIRCLE];
/* Maximum length of list or vector to print in full; noninteger means
effectively infinity */
Lisp_Object Vprint_gensym;
Lisp_Object Vprint_gensym_alist;
-Lisp_Object Qprint_escape_newlines;
-Lisp_Object Qprint_readably;
-
Lisp_Object Qdisplay_error;
Lisp_Object Qprint_message_label;
int stdout_needs_newline;
-/* Write a string (in internal format) to stdio stream STREAM. */
-
-void
-write_string_to_stdio_stream (FILE *stream, struct console *con,
- CONST Bufbyte *str,
- Bytecount offset, Bytecount len,
- enum external_data_format fmt)
+static void
+std_handle_out_external (FILE *stream, Lisp_Object lstream,
+ const Extbyte *extptr, Extcount extlen,
+ /* is this really stdout/stderr?
+ (controls termscript writing) */
+ int output_is_std_handle,
+ int must_flush)
{
- int extlen;
- CONST Extbyte *extptr;
-
- GET_CHARPTR_EXT_DATA_ALLOCA (str + offset, len, fmt, extptr, extlen);
if (stream)
{
- fwrite (extptr, 1, extlen, stream);
#ifdef WINDOWSNT
- /* Q122442 says that pipes are "treated as files, not as
- devices", and that this is a feature. Before I found that
- article, I thought it was a bug. Thanks MS, I feel much
- better now. - kkm */
- if (stream == stdout || stream == stderr)
- fflush (stream);
+ /* we typically have no useful stdout/stderr under windows if we're
+ being invoked graphically. */
+ if (!noninteractive)
+ msw_output_console_string (extptr, extlen);
+ else
#endif
+ {
+ fwrite (extptr, 1, extlen, stream);
+#ifdef WINDOWSNT
+ /* Q122442 says that pipes are "treated as files, not as
+ devices", and that this is a feature. Before I found that
+ article, I thought it was a bug. Thanks MS, I feel much
+ better now. - kkm */
+ must_flush = 1;
+#endif
+ if (must_flush)
+ fflush (stream);
+ }
}
else
- {
- assert (CONSOLE_TTY_P (con));
- Lstream_write (XLSTREAM (CONSOLE_TTY_DATA (con)->outstream),
- extptr, extlen);
- }
- if (stream == stdout || stream == stderr ||
- (!stream && CONSOLE_TTY_DATA (con)->is_stdio))
+ Lstream_write (XLSTREAM (lstream), extptr, extlen);
+
+ if (output_is_std_handle)
{
if (termscript)
{
}
}
+/* #### The following function should be replaced a call to the
+ emacs_doprnt_*() functions. This is the only way to ensure that
+ I18N3 works properly (many implementations of the *printf()
+ functions, including the ones included in glibc, do not implement
+ the %###$ argument-positioning syntax).
+
+ Note, however, that to do this, we'd have to
+
+ 1) pre-allocate all the lstreams and do whatever else was necessary
+ to make sure that no allocation occurs, since these functions may be
+ called from fatal_error_signal().
+
+ 2) (to be really correct) make a new lstream that outputs using
+ msw_output_console_string(). */
+
+static int
+std_handle_out_va (FILE *stream, const char *fmt, va_list args)
+{
+ Bufbyte kludge[8192];
+ Extbyte *extptr;
+ Extcount extlen;
+ int retval;
+
+ retval = vsprintf ((char *) kludge, fmt, args);
+ TO_EXTERNAL_FORMAT (DATA, (kludge, strlen ((char *) kludge)),
+ ALLOCA, (extptr, extlen),
+ Qnative);
+ std_handle_out_external (stream, Qnil, extptr, extlen, 1, 1);
+ return retval;
+}
+
+/* Output portably to stderr or its equivalent; call GETTEXT on the
+ format string. Automatically flush when done. */
+
+int
+stderr_out (const char *fmt, ...)
+{
+ int retval;
+ va_list args;
+ va_start (args, fmt);
+ retval = std_handle_out_va (stderr, GETTEXT (fmt), args);
+ va_end (args);
+ return retval;
+}
+
+/* Output portably to stdout or its equivalent; call GETTEXT on the
+ format string. Automatically flush when done. */
+
+int
+stdout_out (const char *fmt, ...)
+{
+ int retval;
+ va_list args;
+ va_start (args, fmt);
+ retval = std_handle_out_va (stdout, GETTEXT (fmt), args);
+ va_end (args);
+ return retval;
+}
+
+DOESNT_RETURN
+fatal (const char *fmt, ...)
+{
+ va_list args;
+ va_start (args, fmt);
+
+ stderr_out ("\nXEmacs: ");
+ std_handle_out_va (stderr, GETTEXT (fmt), args);
+ stderr_out ("\n");
+
+ va_end (args);
+ exit (1);
+}
+
+/* Write a string (in internal format) to stdio stream STREAM. */
+
+void
+write_string_to_stdio_stream (FILE *stream, struct console *con,
+ const Bufbyte *str,
+ Bytecount offset, Bytecount len,
+ Lisp_Object coding_system,
+ int must_flush)
+{
+ Extcount extlen;
+ const Extbyte *extptr;
+
+ /* #### yuck! sometimes this function is called with string data,
+ and the following call may gc. */
+ {
+ Bufbyte *puta = (Bufbyte *) alloca (len);
+ memcpy (puta, str + offset, len);
+ TO_EXTERNAL_FORMAT (DATA, (puta, len),
+ ALLOCA, (extptr, extlen),
+ coding_system);
+ }
+
+ if (stream)
+ std_handle_out_external (stream, Qnil, extptr, extlen,
+ stream == stdout || stream == stderr, must_flush);
+ else
+ {
+ assert (CONSOLE_TTY_P (con));
+ std_handle_out_external (0, CONSOLE_TTY_DATA (con)->outstream,
+ extptr, extlen,
+ CONSOLE_TTY_DATA (con)->is_stdio, must_flush);
+ }
+}
+
/* Write a string to the output location specified in FUNCTION.
Arguments NONRELOC, RELOC, OFFSET, and LEN are as in
buffer_insert_string_1() in insdel.c. */
static void
-output_string (Lisp_Object function, CONST Bufbyte *nonreloc,
+output_string (Lisp_Object function, const Bufbyte *nonreloc,
Lisp_Object reloc, Bytecount offset, Bytecount len)
{
/* This function can GC */
other functions that take both a nonreloc and a reloc, or things
may get confused and an assertion failure in
fixup_internal_substring() may get triggered. */
- CONST Bufbyte *newnonreloc = nonreloc;
+ const Bufbyte *newnonreloc = nonreloc;
struct gcpro gcpro1, gcpro2;
- /* Emacs won't print whilst GCing, but an external debugger might */
+ /* Emacs won't print while GCing, but an external debugger might */
if (gc_in_progress) return;
/* Perhaps not necessary but probably safer. */
else if (EQ (function, Qt) || EQ (function, Qnil))
{
write_string_to_stdio_stream (stdout, 0, newnonreloc, offset, len,
- FORMAT_TERMINAL);
+ Qterminal, print_unbuffered);
}
else
{
static Lisp_Object
print_prepare (Lisp_Object printcharfun, Lisp_Object *frame_kludge)
{
- /* Emacs won't print whilst GCing, but an external debugger might */
+ /* Emacs won't print while GCing, but an external debugger might */
if (gc_in_progress)
return Qnil;
static void
print_finish (Lisp_Object stream, Lisp_Object frame_kludge)
{
- /* Emacs won't print whilst GCing, but an external debugger might */
+ /* Emacs won't print while GCing, but an external debugger might */
if (gc_in_progress)
return;
clear_echo_area_from_print (f, Qnil, 1);
echo_area_append (f, resizing_buffer_stream_ptr (str),
Qnil, 0, Lstream_byte_count (str),
- Vprint_message_label);
+ Vprint_message_label);
Lstream_delete (str);
}
}
\f
/* Used for printing a single-byte character (*not* any Emchar). */
#define write_char_internal(string_of_length_1, stream) \
- output_string (stream, (CONST Bufbyte *) (string_of_length_1), \
+ output_string (stream, (const Bufbyte *) (string_of_length_1), \
Qnil, 0, 1)
/* NOTE: Do not call this with the data of a Lisp_String, as
canonicalize_printcharfun() (i.e. Qnil means stdout, not
Vstandard_output, etc.) */
void
-write_string_1 (CONST Bufbyte *str, Bytecount size, Lisp_Object stream)
+write_string_1 (const Bufbyte *str, Bytecount size, Lisp_Object stream)
{
/* This function can GC */
#ifdef ERROR_CHECK_BUFPOS
}
void
-write_c_string (CONST char *str, Lisp_Object stream)
+write_c_string (const char *str, Lisp_Object stream)
{
/* This function can GC */
- write_string_1 ((CONST Bufbyte *) str, strlen (str), stream);
+ write_string_1 ((const Bufbyte *) str, strlen (str), stream);
}
\f
}
void
-temp_output_buffer_setup (CONST char *bufname)
+temp_output_buffer_setup (Lisp_Object bufname)
{
/* This function can GC */
struct buffer *old = current_buffer;
so that proper translation on the buffer name can occur. */
#endif
- Fset_buffer (Fget_buffer_create (build_string (bufname)));
+ Fset_buffer (Fget_buffer_create (bufname));
current_buffer->read_only = Qnil;
Ferase_buffer (Qnil);
}
Lisp_Object
-internal_with_output_to_temp_buffer (CONST char *bufname,
+internal_with_output_to_temp_buffer (Lisp_Object bufname,
Lisp_Object (*function) (Lisp_Object arg),
Lisp_Object arg,
Lisp_Object same_frame)
GCPRO3 (buf, arg, same_frame);
- temp_output_buffer_setup (GETTEXT (bufname));
+ temp_output_buffer_setup (bufname);
buf = Vstandard_output;
arg = (*function) (arg);
(args))
{
/* This function can GC */
- struct gcpro gcpro1;
- Lisp_Object name;
+ Lisp_Object name = Qnil;
int speccount = specpdl_depth ();
- Lisp_Object val;
+ struct gcpro gcpro1, gcpro2;
+ Lisp_Object val = Qnil;
#ifdef I18N3
/* #### should set the buffer to be translating. See print_internal(). */
#endif
- GCPRO1 (args);
+ GCPRO2 (name, val);
name = Feval (XCAR (args));
- UNGCPRO;
CHECK_STRING (name);
- temp_output_buffer_setup ((char *) XSTRING_DATA (name));
+
+ temp_output_buffer_setup (name);
+ UNGCPRO;
val = Fprogn (XCDR (args));
{
int first = 1;
int speccount = specpdl_depth ();
+ Lisp_Object frame = Qnil;
+ struct gcpro gcpro1;
+ GCPRO1 (stream);
specbind (Qprint_message_label, Qerror);
+ stream = print_prepare (stream, &frame);
+
tail = Fcdr (error_object);
if (EQ (type, Qerror))
{
tail = Fcdr (tail);
first = 0;
}
+ print_finish (stream, frame);
+ UNGCPRO;
unbind_to (speccount, Qnil);
return;
/* not reached */
#ifdef LISP_FLOAT_TYPE
Lisp_Object Vfloat_output_format;
-Lisp_Object Qfloat_output_format;
/*
* This 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>.
*
faster.
BUFFER should accept 24 bytes. This should suffice for the longest
- numbers on 64-bit machines. */
+ numbers on 64-bit machines, including the `-' sign and the trailing
+ \0. */
void
long_to_string (char *buffer, long number)
{
- char *p;
- int i, len;
+#if (SIZEOF_LONG != 4) && (SIZEOF_LONG != 8)
+ /* Huh? */
+ sprintf (buffer, "%ld", number);
+#else /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
+ char *p = buffer;
+ int force = 0;
if (number < 0)
{
- *buffer++ = '-';
+ *p++ = '-';
number = -number;
}
- p = buffer;
-
- /* Print the digits to the string. */
- do
- {
- *p++ = number % 10 + '0';
- number /= 10;
- }
- while (number);
- /* And reverse them. */
- len = p - buffer - 1;
- for (i = len / 2; i >= 0; i--)
- {
- char c = buffer[i];
- buffer[i] = buffer[len - i];
- buffer[len - i] = c;
- }
- buffer[len + 1] = '\0';
+#define FROB(figure) do { \
+ if (force || number >= figure) \
+ *p++ = number / figure + '0', number %= figure, force = 1; \
+ } while (0)
+#if SIZEOF_LONG == 8
+ FROB (1000000000000000000L);
+ FROB (100000000000000000L);
+ FROB (10000000000000000L);
+ FROB (1000000000000000L);
+ FROB (100000000000000L);
+ FROB (10000000000000L);
+ FROB (1000000000000L);
+ FROB (100000000000L);
+ FROB (10000000000L);
+#endif /* SIZEOF_LONG == 8 */
+ FROB (1000000000);
+ FROB (100000000);
+ FROB (10000000);
+ FROB (1000000);
+ FROB (100000);
+ FROB (10000);
+ FROB (1000);
+ FROB (100);
+ FROB (10);
+#undef FROB
+ *p++ = number + '0';
+ *p = '\0';
+#endif /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
}
\f
static void
-print_vector_internal (CONST char *start, CONST char *end,
+print_vector_internal (const char *start, const char *end,
Lisp_Object obj,
Lisp_Object printcharfun, int escapeflag)
{
write_char_internal ("(", printcharfun);
{
- int i = 0;
- int max = 0;
-
- if (INTP (Vprint_length))
- max = XINT (Vprint_length);
- while (CONSP (obj))
+ int len;
+ int max = INTP (Vprint_length) ? XINT (Vprint_length) : INT_MAX;
+ Lisp_Object tortoise;
+ /* Use tortoise/hare to make sure circular lists don't infloop */
+
+ for (tortoise = obj, len = 0;
+ CONSP (obj);
+ obj = XCDR (obj), len++)
{
- if (i++)
+ if (len > 0)
write_char_internal (" ", printcharfun);
- if (max && i > max)
+ if (EQ (obj, tortoise) && len > 0)
+ {
+ if (print_readably)
+ error ("printing unreadable circular list");
+ else
+ write_c_string ("... <circular list>", printcharfun);
+ break;
+ }
+ if (len & 1)
+ tortoise = XCDR (tortoise);
+ if (len > max)
{
write_c_string ("...", printcharfun);
break;
}
- print_internal (XCAR (obj), printcharfun,
- escapeflag);
- obj = XCDR (obj);
+ print_internal (XCAR (obj), printcharfun, escapeflag);
}
}
if (!LISTP (obj))
print_internal (obj, printcharfun, escapeflag);
}
UNGCPRO;
+
write_char_internal (")", printcharfun);
return;
}
void
print_string (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
{
- struct Lisp_String *s = XSTRING (obj);
+ Lisp_String *s = XSTRING (obj);
/* We distinguish between Bytecounts and Charcounts, to make
Vprint_string_length work correctly under Mule. */
Charcount size = string_char_length (s);
QUIT;
- /* Emacs won't print whilst GCing, but an external debugger might */
+ /* Emacs won't print while GCing, but an external debugger might */
if (gc_in_progress) return;
#ifdef I18N3
switch (XTYPE (obj))
{
-#ifdef USE_MINIMAL_TAGBITS
case Lisp_Type_Int_Even:
case Lisp_Type_Int_Odd:
-#else
- case Lisp_Type_Int:
-#endif
{
- char buf[24];
+ /* ASCII Decimal representation uses 2.4 times as many bits as
+ machine binary. */
+ char buf[3 * sizeof (EMACS_INT) + 5];
long_to_string (buf, XINT (obj));
write_c_string (buf, printcharfun);
break;
Emchar ch = XCHAR (obj);
char *p = buf;
*p++ = '?';
- if (ch == '\n')
- *p++ = '\\', *p++ = 'n';
- else if (ch == '\r')
- *p++ = '\\', *p++ = 'r';
- else if (ch == '\t')
- *p++ = '\\', *p++ = 't';
- else if (ch < 32)
+ if (ch < 32)
{
- *p++ = '\\', *p++ = '^';
- *p++ = ch + 64;
- if ((ch + 64) == '\\')
- *p++ = '\\';
+ *p++ = '\\';
+ switch (ch)
+ {
+ case '\t': *p++ = 't'; break;
+ case '\n': *p++ = 'n'; break;
+ case '\r': *p++ = 'r'; break;
+ default:
+ *p++ = '^';
+ *p++ = ch + 64;
+ if ((ch + 64) == '\\')
+ *p++ = '\\';
+ break;
+ }
+ }
+ else if (ch < 127)
+ {
+ /* syntactically special characters should be escaped. */
+ switch (ch)
+ {
+ case ' ':
+ case '"':
+ case '#':
+ case '\'':
+ case '(':
+ case ')':
+ case ',':
+ case '.':
+ case ';':
+ case '?':
+ case '[':
+ case '\\':
+ case ']':
+ case '`':
+ *p++ = '\\';
+ }
+ *p++ = ch;
}
else if (ch == 127)
- *p++ = '\\', *p++ = '^', *p++ = '?';
- else if (ch >= 128 && ch < 160)
+ {
+ *p++ = '\\', *p++ = '^', *p++ = '?';
+ }
+ else if (ch < 160)
{
*p++ = '\\', *p++ = '^';
- p += set_charptr_emchar ((Bufbyte *)p, ch + 64);
+ p += set_charptr_emchar ((Bufbyte *) p, ch + 64);
}
- else if (ch < 127
- && !isdigit (ch)
- && !isalpha (ch)
- && ch != '^') /* must not backslash this or it will
- be interpreted as the start of a
- control char */
- *p++ = '\\', *p++ = ch;
else
- p += set_charptr_emchar ((Bufbyte *)p, ch);
- output_string (printcharfun, (Bufbyte *)buf, Qnil, 0, p - buf);
- break;
- }
-
-#ifndef LRECORD_STRING
- case Lisp_Type_String:
- {
- print_string (obj, printcharfun, escapeflag);
- break;
- }
-#endif /* ! LRECORD_STRING */
-
-#ifndef LRECORD_CONS
- case Lisp_Type_Cons:
- {
- struct gcpro gcpro1, gcpro2;
-
- /* If deeper than spec'd depth, print placeholder. */
- if (INTP (Vprint_level)
- && print_depth > XINT (Vprint_level))
{
- GCPRO2 (obj, printcharfun);
- write_c_string ("...", printcharfun);
- UNGCPRO;
- break;
+ p += set_charptr_emchar ((Bufbyte *) p, ch);
}
- print_cons (obj, printcharfun, escapeflag);
- break;
- }
-#endif /* ! LRECORD_CONS */
-
-#ifndef LRECORD_VECTOR
- case Lisp_Type_Vector:
- {
- /* If deeper than spec'd depth, print placeholder. */
- if (INTP (Vprint_level)
- && print_depth > XINT (Vprint_level))
- {
- struct gcpro gcpro1, gcpro2;
- GCPRO2 (obj, printcharfun);
- write_c_string ("...", printcharfun);
- UNGCPRO;
- break;
- }
+ output_string (printcharfun, (Bufbyte *) buf, Qnil, 0, p - buf);
- /* God intended that this be #(...), you know. */
- print_vector_internal ("[", "]", obj, printcharfun, escapeflag);
break;
}
-#endif /* !LRECORD_VECTOR */
-
-#ifndef LRECORD_SYMBOL
- case Lisp_Type_Symbol:
- {
- print_symbol (obj, printcharfun, escapeflag);
- break;
- }
-#endif /* !LRECORD_SYMBOL */
case Lisp_Type_Record:
{
struct lrecord_header *lheader = XRECORD_LHEADER (obj);
struct gcpro gcpro1, gcpro2;
-#if defined(LRECORD_CONS) || defined(LRECORD_VECTOR)
if (CONSP (obj) || VECTORP(obj))
{
/* If deeper than spec'd depth, print placeholder. */
break;
}
}
-#endif
GCPRO2 (obj, printcharfun);
if (LHEADER_IMPLEMENTATION (lheader)->printer)
print_depth--;
}
-static void
-print_compiled_function_internal (CONST char *start, CONST char *end,
- Lisp_Object obj,
- Lisp_Object printcharfun, int escapeflag)
-{
- /* This function can GC */
- struct Lisp_Compiled_Function *b =
- XCOMPILED_FUNCTION (obj); /* GC doesn't relocate */
- int docp = b->flags.documentationp;
- int intp = b->flags.interactivep;
- struct gcpro gcpro1, gcpro2;
- char buf[100];
- GCPRO2 (obj, printcharfun);
-
- write_c_string (start, printcharfun);
-#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
- if (!print_readably)
- {
- Lisp_Object ann = compiled_function_annotation (b);
- if (!NILP (ann))
- {
- write_c_string ("(from ", printcharfun);
- print_internal (ann, printcharfun, 1);
- write_c_string (") ", printcharfun);
- }
- }
-#endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
- /* COMPILED_ARGLIST = 0 */
- print_internal (b->arglist, printcharfun, escapeflag);
- /* COMPILED_BYTECODE = 1 */
- write_char_internal (" ", printcharfun);
- /* we don't really want to see that junk in the bytecode instructions. */
- if (STRINGP (b->bytecodes) && !print_readably)
- {
- sprintf (buf, "\"...(%ld)\"", (long) XSTRING_LENGTH (b->bytecodes));
- write_c_string (buf, printcharfun);
- }
- else
- print_internal (b->bytecodes, printcharfun, escapeflag);
- /* COMPILED_CONSTANTS = 2 */
- write_char_internal (" ", printcharfun);
- print_internal (b->constants, printcharfun, escapeflag);
- /* COMPILED_STACK_DEPTH = 3 */
- sprintf (buf, " %d", b->maxdepth);
- write_c_string (buf, printcharfun);
- /* COMPILED_DOC_STRING = 4 */
- if (docp || intp)
- {
- write_char_internal (" ", printcharfun);
- print_internal (compiled_function_documentation (b), printcharfun,
- escapeflag);
- }
- /* COMPILED_INTERACTIVE = 5 */
- if (intp)
- {
- write_char_internal (" ", printcharfun);
- print_internal (compiled_function_interactive (b), printcharfun,
- escapeflag);
- }
- UNGCPRO;
- write_c_string (end, printcharfun);
-}
-
-void
-print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun,
- int escapeflag)
-{
- /* This function can GC */
- print_compiled_function_internal (((print_readably) ? "#[" :
- "#<compiled-function "),
- ((print_readably) ? "]" : ">"),
- obj, printcharfun, escapeflag);
-}
#ifdef LISP_FLOAT_TYPE
void
{
char pigbuf[350]; /* see comments in float_to_string */
- float_to_string (pigbuf, float_data (XFLOAT (obj)));
+ float_to_string (pigbuf, XFLOAT_DATA (obj));
write_c_string (pigbuf, printcharfun);
}
#endif /* LISP_FLOAT_TYPE */
/* This function can GC */
/* #### Bug!! (intern "") isn't printed in some distinguished way */
/* #### (the reader also loses on it) */
- struct Lisp_String *name = symbol_name (XSYMBOL (obj));
+ Lisp_String *name = symbol_name (XSYMBOL (obj));
Bytecount size = string_length (name);
struct gcpro gcpro1, gcpro2;
/* If we print an uninterned symbol as part of a complex object and
the flag print-gensym is non-nil, prefix it with #n= to read the
object back with the #n# reader syntax later if needed. */
- if (!NILP (Vprint_gensym) && NILP (XSYMBOL (obj)->obarray))
+ if (!NILP (Vprint_gensym)
+ /* #### Test whether this produces a noticable slow-down for
+ printing when print-gensym is non-nil. */
+ && !EQ (obj, oblookup (Vobarray,
+ string_data (symbol_name (XSYMBOL (obj))),
+ string_length (symbol_name (XSYMBOL (obj))))))
{
if (print_depth > 1)
{
XSETSTRING (nameobj, name);
for (i = 0; i < size; i++)
{
- Bufbyte c = string_byte (name, i);
-
- if (c == '\"' || c == '\\' || c == '\'' || c == ';' || c == '#' ||
- c == '(' || c == ')' || c == ',' || c =='.' || c == '`' ||
- c == '[' || c == ']' || c == '?' || c <= 040)
+ switch (string_byte (name, i))
{
+ case 0: case 1: case 2: case 3:
+ case 4: case 5: case 6: case 7:
+ case 8: case 9: case 10: case 11:
+ case 12: case 13: case 14: case 15:
+ case 16: case 17: case 18: case 19:
+ case 20: case 21: case 22: case 23:
+ case 24: case 25: case 26: case 27:
+ case 28: case 29: case 30: case 31:
+ case ' ': case '\"': case '\\': case '\'':
+ case ';': case '#' : case '(' : case ')':
+ case ',': case '.' : case '`' :
+ case '[': case ']' : case '?' :
if (i > last)
- {
- output_string (printcharfun, 0, nameobj, last,
- i - last);
- }
+ output_string (printcharfun, 0, nameobj, last, i - last);
write_char_internal ("\\", printcharfun);
last = i;
}
getting rid of this function altogether? Does anything actually
*use* it? --hniksic */
-int alternate_do_pointer;
-char alternate_do_string[5000];
+static int alternate_do_pointer;
+static char alternate_do_string[5000];
DEFUN ("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0, /*
Append CHARACTER to the array `alternate_do_string'.
Bufbyte str[MAX_EMCHAR_LEN];
Bytecount len;
int extlen;
- CONST Extbyte *extptr;
+ const Extbyte *extptr;
CHECK_CHAR_COERCE_INT (character);
len = set_charptr_emchar (str, XCHAR (character));
- GET_CHARPTR_EXT_DATA_ALLOCA (str, len, FORMAT_TERMINAL, extptr, extlen);
+ TO_EXTERNAL_FORMAT (DATA, (str, len),
+ ALLOCA, (extptr, extlen),
+ Qterminal);
memcpy (alternate_do_string + alternate_do_pointer, extptr, extlen);
alternate_do_pointer += extlen;
alternate_do_string[alternate_do_pointer] = 0;
to stderr. You can use this function to write directly to the terminal.
This function can be used as the STREAM argument of Fprint() or the like.
+Under MS Windows, this writes output to the console window (which is
+created, if necessary), unless XEmacs is being run noninteractively
+(i.e. using the `-batch' argument).
+
If you have opened a termscript file (using `open-termscript'), then
the output also will be logged to this file.
*/
if (DEVICE_TTY_P (XDEVICE (device)))
file = 0;
else if (!NILP (stdout_p))
- file = CONSOLE_STREAM_DATA (con)->outfd;
+ file = CONSOLE_STREAM_DATA (con)->out;
else
- file = CONSOLE_STREAM_DATA (con)->errfd;
+ file = CONSOLE_STREAM_DATA (con)->err;
}
if (STRINGP (char_or_string))
write_string_to_stdio_stream (file, con,
XSTRING_DATA (char_or_string),
0, XSTRING_LENGTH (char_or_string),
- FORMAT_TERMINAL);
+ Qterminal, 1);
else
{
Bufbyte str[MAX_EMCHAR_LEN];
CHECK_CHAR_COERCE_INT (char_or_string);
len = set_charptr_emchar (str, XCHAR (char_or_string));
- write_string_to_stdio_stream (file, con, str, 0, len, FORMAT_TERMINAL);
+ write_string_to_stdio_stream (file, con, str, 0, len, Qterminal, 1);
}
return char_or_string;
#if 1
/* Debugging kludge -- unbuffered */
-static int debug_print_length = 50;
-static int debug_print_level = 15;
-Lisp_Object debug_temp;
+static int debug_print_length = 50;
+static int debug_print_level = 15;
+static int debug_print_readably = -1;
static void
debug_print_no_newline (Lisp_Object debug_print_obj)
{
/* This function can GC */
- int old_print_readably = print_readably;
- int old_print_depth = print_depth;
- Lisp_Object old_print_length = Vprint_length;
- Lisp_Object old_print_level = Vprint_level;
- Lisp_Object old_inhibit_quit = Vinhibit_quit;
+ int save_print_readably = print_readably;
+ int save_print_depth = print_depth;
+ Lisp_Object save_Vprint_length = Vprint_length;
+ Lisp_Object save_Vprint_level = Vprint_level;
+ Lisp_Object save_Vinhibit_quit = Vinhibit_quit;
struct gcpro gcpro1, gcpro2, gcpro3;
- GCPRO3 (old_print_level, old_print_length, old_inhibit_quit);
+ GCPRO3 (save_Vprint_level, save_Vprint_length, save_Vinhibit_quit);
if (gc_in_progress)
stderr_out ("** gc-in-progress! Bad idea to print anything! **\n");
print_depth = 0;
- print_readably = 0;
+ print_readably = debug_print_readably != -1 ? debug_print_readably : 0;
print_unbuffered++;
/* Could use unwind-protect, but why bother? */
if (debug_print_length > 0)
Vprint_length = make_int (debug_print_length);
if (debug_print_level > 0)
Vprint_level = make_int (debug_print_level);
+
print_internal (debug_print_obj, Qexternal_debugging_output, 1);
- Vinhibit_quit = old_inhibit_quit;
- Vprint_level = old_print_level;
- Vprint_length = old_print_length;
- print_depth = old_print_depth;
- print_readably = old_print_readably;
+
+ Vinhibit_quit = save_Vinhibit_quit;
+ Vprint_level = save_Vprint_level;
+ Vprint_length = save_Vprint_length;
+ print_depth = save_print_depth;
+ print_readably = save_print_readably;
print_unbuffered--;
UNGCPRO;
}
{
debug_print_no_newline (debug_print_obj);
stderr_out ("\n");
- fflush (stderr);
}
/* Debugging kludge -- unbuffered */
debug_backtrace (void)
{
/* This function can GC */
- int old_print_readably = print_readably;
- int old_print_depth = print_depth;
- Lisp_Object old_print_length = Vprint_length;
- Lisp_Object old_print_level = Vprint_level;
- Lisp_Object old_inhibit_quit = Vinhibit_quit;
+ int old_print_readably = print_readably;
+ int old_print_depth = print_depth;
+ Lisp_Object old_print_length = Vprint_length;
+ Lisp_Object old_print_level = Vprint_level;
+ Lisp_Object old_inhibit_quit = Vinhibit_quit;
+
struct gcpro gcpro1, gcpro2, gcpro3;
GCPRO3 (old_print_level, old_print_length, old_inhibit_quit);
Vprint_length = make_int (debug_print_length);
if (debug_print_level > 0)
Vprint_level = make_int (debug_print_level);
+
Fbacktrace (Qexternal_debugging_output, Qt);
stderr_out ("\n");
- fflush (stderr);
- Vinhibit_quit = old_inhibit_quit;
- Vprint_level = old_print_level;
- Vprint_length = old_print_length;
- print_depth = old_print_depth;
+
+ Vinhibit_quit = old_inhibit_quit;
+ Vprint_level = old_print_level;
+ Vprint_length = old_print_length;
+ print_depth = old_print_depth;
print_readably = old_print_readably;
print_unbuffered--;
+
UNGCPRO;
}
int first = 1;
struct backtrace *bt = backtrace_list;
stderr_out (" [");
- fflush (stderr);
while (length > 0 && bt)
{
if (!first)
{
stderr_out (", ");
- fflush (stderr);
}
if (COMPILED_FUNCTIONP (*bt->function))
{
#if defined(COMPILED_FUNCTION_ANNOTATION_HACK)
- Lisp_Object ann = Fcompiled_function_annotation (*bt->function);
+ Lisp_Object ann =
+ compiled_function_annotation (XCOMPILED_FUNCTION (*bt->function));
#else
Lisp_Object ann = Qnil;
#endif
if (!NILP (ann))
{
stderr_out ("<compiled-function from ");
- fflush (stderr);
debug_print_no_newline (ann);
stderr_out (">");
- fflush (stderr);
}
else
{
stderr_out ("<compiled-function of unknown origin>");
- fflush (stderr);
}
}
else
bt = bt->next;
}
stderr_out ("]\n");
- fflush (stderr);
}
#endif /* debugging kludge */
void
syms_of_print (void)
{
- defsymbol (&Qprint_escape_newlines, "print-escape-newlines");
- defsymbol (&Qprint_readably, "print-readably");
-
defsymbol (&Qstandard_output, "standard-output");
-#ifdef LISP_FLOAT_TYPE
- defsymbol (&Qfloat_output_format, "float-output-format");
-#endif
-
defsymbol (&Qprint_length, "print-length");
defsymbol (&Qprint_string_length, "print-string-length");
DEFSUBR (Fterpri);
DEFSUBR (Fwrite_char);
DEFSUBR (Falternate_debugging_output);
- defsymbol (&Qalternate_debugging_output, "alternate-debugging-output");
DEFSUBR (Fexternal_debugging_output);
DEFSUBR (Fopen_termscript);
defsymbol (&Qexternal_debugging_output, "external-debugging-output");
}
void
-vars_of_print (void)
+reinit_vars_of_print (void)
{
alternate_do_pointer = 0;
+}
+
+void
+vars_of_print (void)
+{
+ reinit_vars_of_print ();
DEFVAR_LISP ("standard-output", &Vstandard_output /*
Output stream `print' uses by default for outputting a character.
projects / chise / xemacs-chise.git.1 / blobdiff