/* Lisp object printing and output streams.
Copyright (C) 1985, 1986, 1988, 1992-1995 Free Software Foundation, Inc.
- Copyright (C) 1995, 1996, 2000 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 WINDOWSNT
+#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;
-#ifdef WINDOWSNT
-static int no_useful_stderr;
-#endif
-
static void
std_handle_out_external (FILE *stream, Lisp_Object lstream,
const Extbyte *extptr, Extcount extlen,
{
if (stream)
{
-#ifdef WINDOWSNT
- if (!no_useful_stderr)
- no_useful_stderr = GetStdHandle (STD_ERROR_HANDLE) == 0 ? 1 : -1;
+#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 (!noninteractive || no_useful_stderr > 0)
- msw_output_console_string (extptr, extlen);
+ if (no_useful_stderr)
+ mswindows_output_console_string (extptr, extlen);
else
#endif
{
fwrite (extptr, 1, extlen, stream);
-#ifdef WINDOWSNT
+#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
called from fatal_error_signal().
2) (to be really correct) make a new lstream that outputs using
- msw_output_console_string(). */
+ mswindows_output_console_string(). */
static int
std_handle_out_va (FILE *stream, const char *fmt, va_list args)
int retval;
retval = vsprintf ((char *) kludge, fmt, args);
- if (initialized && !fatal_error_in_progress)
+ if (initialized && !inhibit_non_essential_printing_operations)
TO_EXTERNAL_FORMAT (DATA, (kludge, strlen ((char *) kludge)),
ALLOCA, (extptr, extlen),
Qnative);
extptr = (Extbyte *) kludge;
extlen = (Extcount) strlen ((char *) kludge);
}
-
+
std_handle_out_external (stream, Qnil, extptr, extlen, 1, 1);
return retval;
}
{
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)
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;
#undef FROB
*p++ = 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.
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).
+\(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.
}
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;
}
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);
Vprint_length = old_print_length;
print_depth = old_print_depth;
print_readably = old_print_readably;
+ inhibit_non_essential_printing_operations = 0;
print_unbuffered--;
UNGCPRO;
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);
}
projects / chise / xemacs-chise.git.1 / blobdiff