/* 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, 2002 Ben Wing.
This file is part of XEmacs.
#include "insdel.h"
#include "lstream.h"
#include "sysfile.h"
+#ifdef WIN32_NATIVE
+#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 Qexternal_debugging_output, Qalternate_debugging_output;
+
+#ifdef HAVE_MS_WINDOWS
+Lisp_Object Qmswindows_debugging_output;
+#endif
/* Avoid actual stack overflow in print. */
static int print_depth;
int stdout_needs_newline;
+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)
+{
+ if (stream)
+ {
+#ifdef WIN32_NATIVE
+ HANDLE errhand = GetStdHandle (STD_INPUT_HANDLE);
+ int no_useful_stderr = errhand == 0 || errhand == INVALID_HANDLE_VALUE;
+
+ if (!no_useful_stderr)
+ no_useful_stderr = !PeekNamedPipe (errhand, 0, 0, 0, 0, 0);
+ /* we typically have no useful stdout/stderr under windows if we're
+ being invoked graphically. */
+ if (no_useful_stderr)
+ mswindows_output_console_string (extptr, extlen);
+ else
+#endif
+ {
+ fwrite (extptr, 1, extlen, stream);
+#ifdef WIN32_NATIVE
+ /* 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
+ Lstream_write (XLSTREAM (lstream), extptr, extlen);
+
+ if (output_is_std_handle)
+ {
+ if (termscript)
+ {
+ fwrite (extptr, 1, extlen, termscript);
+ fflush (termscript);
+ }
+ stdout_needs_newline = (extptr[extlen - 1] != '\n');
+ }
+}
+
+/* #### 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
+ mswindows_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);
+ if (initialized && !inhibit_non_essential_printing_operations)
+ TO_EXTERNAL_FORMAT (DATA, (kludge, strlen ((char *) kludge)),
+ ALLOCA, (extptr, extlen),
+ Qnative);
+ else
+ {
+ extptr = (Extbyte *) kludge;
+ extlen = (Extcount) strlen ((char *) kludge);
+ }
+
+ 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, initialized && !fatal_error_in_progress ? GETTEXT (fmt) : 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, initialized && !fatal_error_in_progress ? GETTEXT (fmt) : 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)
+ Lisp_Object coding_system,
+ int must_flush)
{
Extcount extlen;
const Extbyte *extptr;
- TO_EXTERNAL_FORMAT (DATA, (str + offset, len),
- ALLOCA, (extptr, extlen),
- coding_system);
+ /* #### 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);
+
+ if (initialized && !inhibit_non_essential_printing_operations)
+ TO_EXTERNAL_FORMAT (DATA, (puta, len),
+ ALLOCA, (extptr, extlen),
+ coding_system);
+ else
+ {
+ extptr = (Extbyte *) puta;
+ extlen = (Bytecount) len;
+ }
+ }
+
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);
-#endif
- }
+ std_handle_out_external (stream, Qnil, extptr, extlen,
+ stream == stdout || stream == stderr, must_flush);
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))
- {
- if (termscript)
- {
- fwrite (extptr, 1, extlen, termscript);
- fflush (termscript);
- }
- stdout_needs_newline = (extptr[extlen - 1] != '\n');
+ std_handle_out_external (0, CONSOLE_TTY_DATA (con)->outstream,
+ extptr, extlen,
+ CONSOLE_TTY_DATA (con)->is_stdio, must_flush);
}
}
else if (EQ (function, Qt) || EQ (function, Qnil))
{
write_string_to_stdio_stream (stdout, 0, newnonreloc, offset, len,
- Qterminal);
+ Qterminal, print_unbuffered);
}
else
{
write_string_1 ((const Bufbyte *) str, strlen (str), stream);
}
+static void
+write_fmt_string (Lisp_Object stream, const char *fmt, ...)
+{
+ va_list va;
+ char bigbuf[666];
+
+ va_start (va, fmt);
+ vsprintf (bigbuf, fmt, va);
+ va_end (va);
+ write_c_string (bigbuf, stream);
+}
+
\f
DEFUN ("write-char", Fwrite_char, 1, 2, 0, /*
-Output character CH to stream STREAM.
+Output character CHARACTER to stream STREAM.
STREAM defaults to the value of `standard-output' (which see).
*/
- (ch, stream))
+ (character, stream))
{
/* This function can GC */
Bufbyte str[MAX_EMCHAR_LEN];
Bytecount len;
- CHECK_CHAR_COERCE_INT (ch);
- len = set_charptr_emchar (str, XCHAR (ch));
+ CHECK_CHAR_COERCE_INT (character);
+ len = set_charptr_emchar (str, XCHAR (character));
output_string (canonicalize_printcharfun (stream), str, Qnil, 0, len);
- return ch;
+ return character;
}
void
Output the printed representation of OBJECT, any Lisp object.
No quoting characters are used; no delimiters are printed around
the contents of strings.
-Output stream is STREAM, or value of standard-output (which see).
+Output stream is STREAM, or value of `standard-output' (which see).
*/
(object, stream))
{
}
#endif /* LISP_FLOAT_TYPE */
-/* Print NUMBER to BUFFER. The digits are first written in reverse
- order (the least significant digit first), and are then reversed.
- This is equivalent to sprintf(buffer, "%ld", number), only much
- faster.
+/* Print NUMBER to BUFFER.
+ This is equivalent to sprintf (buffer, "%ld", number), only much faster.
BUFFER should accept 24 bytes. This should suffice for the longest
numbers on 64-bit machines, including the `-' sign and the trailing
- \0. */
-void
+ '\0'. Returns a pointer to the trailing '\0'. */
+char *
long_to_string (char *buffer, long number)
{
#if (SIZEOF_LONG != 4) && (SIZEOF_LONG != 8)
/* Huh? */
sprintf (buffer, "%ld", number);
+ return buffer + strlen (buffer);
#else /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
char *p = buffer;
int force = 0;
number = -number;
}
-#define FROB(figure) do { \
- if (force || number >= figure) \
- *p++ = number / figure + '0', number %= figure, force = 1; \
+#define FROB(figure) do { \
+ if (force || number >= figure) \
+ *p++ = (char) (number / figure + '0'), number %= figure, force = 1; \
} while (0)
#if SIZEOF_LONG == 8
FROB (1000000000000000000L);
FROB (100);
FROB (10);
#undef FROB
- *p++ = number + '0';
+ *p++ = (char) (number + '0');
*p = '\0';
+ return p;
#endif /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
}
\f
write_c_string (buf, printcharfun);
}
+enum printing_badness
+{
+ BADNESS_INTEGER_OBJECT,
+ BADNESS_POINTER_OBJECT,
+ BADNESS_NO_TYPE
+};
+
+static void
+printing_major_badness (Lisp_Object printcharfun,
+ Char_ASCII *badness_string, int type, void *val,
+ enum printing_badness badness)
+{
+ char buf[666];
+
+ switch (badness)
+ {
+ case BADNESS_INTEGER_OBJECT:
+ sprintf (buf, "%s %d object %ld", badness_string, type,
+ (EMACS_INT) val);
+ break;
+
+ case BADNESS_POINTER_OBJECT:
+ sprintf (buf, "%s %d object %p", badness_string, type, val);
+ break;
+
+ case BADNESS_NO_TYPE:
+ sprintf (buf, "%s object %p", badness_string, val);
+ break;
+ }
+
+ /* Don't ABORT or signal if called from debug_print() or already
+ crashing */
+ if (!inhibit_non_essential_printing_operations)
+ {
+#ifdef ERROR_CHECK_TYPES
+ ABORT ();
+#else /* not ERROR_CHECK_TYPES */
+ if (print_readably)
+ type_error (Qinternal_error, "printing %s", buf);
+#endif /* not ERROR_CHECK_TYPES */
+ }
+ write_fmt_string (printcharfun,
+ "#<EMACS BUG: %s Save your buffers immediately and "
+ "please report this bug>", buf);
+}
+
void
print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
{
case Lisp_Type_Record:
{
struct lrecord_header *lheader = XRECORD_LHEADER (obj);
- struct gcpro gcpro1, gcpro2;
- if (CONSP (obj) || VECTORP(obj))
+ /* Try to check for various sorts of bogus pointers if we're in a
+ situation where it may be likely -- i.e. called from
+ debug_print() or we're already crashing. In such cases,
+ (further) crashing is counterproductive. */
+
+ if (inhibit_non_essential_printing_operations &&
+ !debug_can_access_memory (lheader, sizeof (*lheader)))
+ {
+ write_fmt_string (printcharfun,
+ "#<EMACS BUG: BAD MEMORY ACCESS %p>",
+ lheader);
+ break;
+ }
+
+ if (CONSP (obj) || VECTORP (obj))
{
/* 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;
}
}
- GCPRO2 (obj, printcharfun);
+ if (lheader->type == lrecord_type_free)
+ {
+ printing_major_badness (printcharfun, "freed lrecord", 0,
+ lheader, BADNESS_NO_TYPE);
+ break;
+ }
+ else if (lheader->type == lrecord_type_undefined)
+ {
+ printing_major_badness (printcharfun, "lrecord_type_undefined", 0,
+ lheader, BADNESS_NO_TYPE);
+ break;
+ }
+ else if (lheader->type >= lrecord_type_count)
+ {
+ printing_major_badness (printcharfun, "illegal lrecord type",
+ (int) (lheader->type),
+ lheader, BADNESS_POINTER_OBJECT);
+ break;
+ }
+
+ /* Further checks for bad memory in critical situations. We don't
+ normally do these because they may be expensive or weird
+ (e.g. under Unix we typically have to set a SIGSEGV handler and
+ try to trigger a seg fault). */
+
+ if (inhibit_non_essential_printing_operations)
+ {
+ const struct lrecord_implementation *imp =
+ LHEADER_IMPLEMENTATION (lheader);
+
+ if (!debug_can_access_memory
+ (lheader, imp->size_in_bytes_method ?
+ imp->size_in_bytes_method (lheader) :
+ imp->static_size))
+ {
+ write_fmt_string (printcharfun,
+ "#<EMACS BUG: type %s BAD MEMORY ACCESS %p>",
+ LHEADER_IMPLEMENTATION (lheader)->name,
+ lheader);
+ break;
+ }
+
+ if (STRINGP (obj))
+ {
+ Lisp_String *l = (Lisp_String *) lheader;
+ if (!debug_can_access_memory (l->data, l->size))
+ {
+ write_fmt_string
+ (printcharfun,
+ "#<EMACS BUG: %p (CAN'T ACCESS STRING DATA %p)>",
+ lheader, l->data);
+ break;
+ }
+ }
+ }
+
if (LHEADER_IMPLEMENTATION (lheader)->printer)
((LHEADER_IMPLEMENTATION (lheader)->printer)
(obj, printcharfun, escapeflag));
else
default_object_printer (obj, printcharfun, escapeflag);
- UNGCPRO;
break;
}
default:
{
-#ifdef ERROR_CHECK_TYPECHECK
- abort ();
-#else /* not ERROR_CHECK_TYPECHECK */
- char buf[128];
/* We're in trouble if this happens! */
- if (print_readably)
- error ("printing illegal data type #o%03o",
- (int) XTYPE (obj));
- write_c_string ("#<EMACS BUG: ILLEGAL DATATYPE ",
- printcharfun);
- sprintf (buf, "(#o%3o)", (int) XTYPE (obj));
- write_c_string (buf, printcharfun);
- write_c_string
- (" Save your buffers immediately and please report this bug>",
- printcharfun);
-#endif /* not ERROR_CHECK_TYPECHECK */
+ printing_major_badness (printcharfun, "illegal data type", XTYPE (obj),
+ LISP_TO_VOID (obj), BADNESS_INTEGER_OBJECT);
break;
}
}
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)
- /* #### Test whether this produces a noticable slow-down for
+ /* #### Test whether this produces a noticeable slow-down for
printing when print-gensym is non-nil. */
&& !EQ (obj, oblookup (Vobarray,
string_data (symbol_name (XSYMBOL (obj))),
write_char_internal ("#", printcharfun);
print_internal (XCDR (tem), printcharfun, escapeflag);
write_char_internal ("#", printcharfun);
+ UNGCPRO;
return;
}
else
UNGCPRO;
}
\f
-/* #ifdef DEBUG_XEMACS */
-/* I don't like seeing `Note: Strange doc (not fboundp) for function
- alternate-debugging-output @ 429542' -slb */
-/* #### Eek! Any clue how to get rid of it? In fact, how about
- getting rid of this function altogether? Does anything actually
- *use* it? --hniksic */
+/* Useful on systems or in places where writing to stdout is unavailable or
+ not working. */
static int alternate_do_pointer;
static char alternate_do_string[5000];
alternate_do_string[alternate_do_pointer] = 0;
return character;
}
-/* #endif / * DEBUG_XEMACS */
DEFUN ("external-debugging-output", Fexternal_debugging_output, 1, 3, 0, /*
Write CHAR-OR-STRING to stderr or stdout.
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.
*/
write_string_to_stdio_stream (file, con,
XSTRING_DATA (char_or_string),
0, XSTRING_LENGTH (char_or_string),
- Qterminal);
+ 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, Qterminal);
+ write_string_to_stdio_stream (file, con, str, 0, len, Qterminal, 1);
}
return char_or_string;
}
DEFUN ("open-termscript", Fopen_termscript, 1, 1, "FOpen termscript file: ", /*
-Start writing all terminal output to FILE as well as the terminal.
-FILE = nil means just close any termscript file currently open.
+Start writing all terminal output to FILENAME as well as the terminal.
+FILENAME = nil means just close any termscript file currently open.
*/
- (file))
+ (filename))
{
/* This function can GC */
if (termscript != 0)
- fclose (termscript);
- termscript = 0;
+ {
+ fclose (termscript);
+ termscript = 0;
+ }
- if (! NILP (file))
+ if (! NILP (filename))
{
- file = Fexpand_file_name (file, Qnil);
- termscript = fopen ((char *) XSTRING_DATA (file), "w");
+ filename = Fexpand_file_name (filename, Qnil);
+ termscript = fopen ((char *) XSTRING_DATA (filename), "w");
if (termscript == NULL)
- report_file_error ("Opening termscript", list1 (file));
+ report_file_error ("Opening termscript", list1 (filename));
}
return Qnil;
}
print_depth = 0;
print_readably = debug_print_readably != -1 ? debug_print_readably : 0;
print_unbuffered++;
+ inhibit_non_essential_printing_operations = 1;
/* Could use unwind-protect, but why bother? */
if (debug_print_length > 0)
Vprint_length = make_int (debug_print_length);
Vprint_level = make_int (debug_print_level);
print_internal (debug_print_obj, Qexternal_debugging_output, 1);
+ alternate_do_pointer = 0;
+ print_internal (debug_print_obj, Qalternate_debugging_output, 1);
+#ifdef WIN32_NATIVE
+ /* Write out to the debugger, as well */
+ print_internal (debug_print_obj, Qmswindows_debugging_output, 1);
+#endif
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;
+ inhibit_non_essential_printing_operations = 0;
print_unbuffered--;
UNGCPRO;
}
{
debug_print_no_newline (debug_print_obj);
stderr_out ("\n");
- fflush (stderr);
}
/* Debugging kludge -- unbuffered */
print_depth = 0;
print_readably = 0;
print_unbuffered++;
+ inhibit_non_essential_printing_operations = 1;
/* Could use unwind-protect, but why bother? */
if (debug_print_length > 0)
Vprint_length = make_int (debug_print_length);
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;
print_readably = old_print_readably;
+ inhibit_non_essential_printing_operations = 0;
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 (!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 */
DEFSUBR (Fexternal_debugging_output);
DEFSUBR (Fopen_termscript);
defsymbol (&Qexternal_debugging_output, "external-debugging-output");
+ defsymbol (&Qalternate_debugging_output, "alternate-debugging-output");
+#ifdef HAVE_MS_WINDOWS
+ defsymbol (&Qmswindows_debugging_output, "mswindows-debugging-output");
+#endif
DEFSUBR (Fwith_output_to_temp_buffer);
}