X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=src%2Fprint.c;h=3adf779f9d0bab569f4058f7cd74ed71c75204f0;hb=3f711eea68ce5fd586297b43c8d9936cd2ba916f;hp=981e4f8d287a2113d53fc7542940394fc13c5777;hpb=3e447015251ce6dcde843cbed10d9033d5538622;p=chise%2Fxemacs-chise.git.1 diff --git a/src/print.c b/src/print.c index 981e4f8..3adf779 100644 --- a/src/print.c +++ b/src/print.c @@ -1,6 +1,6 @@ /* 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. @@ -38,8 +38,10 @@ Boston, MA 02111-1307, USA. */ #include "insdel.h" #include "lstream.h" #include "sysfile.h" +#ifdef WIN32_NATIVE +#include "console-msw.h" +#endif -#include #include /* Define if not in float.h */ #ifndef DBL_DIG @@ -50,7 +52,11 @@ Lisp_Object Vstandard_output, Qstandard_output; /* 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; @@ -103,47 +109,179 @@ FILE *termscript; /* Stdio stream being used for copy of all output. */ 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); } } @@ -238,7 +376,7 @@ output_string (Lisp_Object function, const Bufbyte *nonreloc, else if (EQ (function, Qt) || EQ (function, Qnil)) { write_string_to_stdio_stream (stdout, 0, newnonreloc, offset, len, - Qterminal); + Qterminal, print_unbuffered); } else { @@ -376,21 +514,33 @@ write_c_string (const char *str, Lisp_Object 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); +} + 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 @@ -542,7 +692,7 @@ DEFUN ("princ", Fprinc, 1, 2, 0, /* 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)) { @@ -804,20 +954,19 @@ float_to_string (char *buf, double data) } #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; @@ -828,9 +977,9 @@ long_to_string (char *buffer, long number) 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); @@ -853,8 +1002,9 @@ long_to_string (char *buffer, long number) FROB (100); FROB (10); #undef FROB - *p++ = number + '0'; + *p++ = (char) (number + '0'); *p = '\0'; + return p; #endif /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */ } @@ -1066,6 +1216,52 @@ internal_object_printer (Lisp_Object obj, Lisp_Object printcharfun, 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, + "#", buf); +} + void print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { @@ -1191,49 +1387,101 @@ 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, + "#", + 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, + "#", + 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, + "#", + 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 ("#", - printcharfun); -#endif /* not ERROR_CHECK_TYPECHECK */ + printing_major_badness (printcharfun, "illegal data type", XTYPE (obj), + LISP_TO_VOID (obj), BADNESS_INTEGER_OBJECT); break; } } @@ -1277,7 +1525,7 @@ print_symbol (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 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))), @@ -1291,6 +1539,7 @@ print_symbol (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) write_char_internal ("#", printcharfun); print_internal (XCDR (tem), printcharfun, escapeflag); write_char_internal ("#", printcharfun); + UNGCPRO; return; } else @@ -1385,13 +1634,9 @@ print_symbol (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) UNGCPRO; } -/* #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]; @@ -1419,7 +1664,6 @@ to 0. 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. @@ -1427,6 +1671,10 @@ If optional arg STDOUT-P is non-nil, write to stdout; otherwise, write 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. */ @@ -1461,7 +1709,7 @@ 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]; @@ -1469,29 +1717,31 @@ the output also will be logged to this file. 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; } @@ -1520,6 +1770,7 @@ debug_print_no_newline (Lisp_Object debug_print_obj) 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); @@ -1527,12 +1778,19 @@ debug_print_no_newline (Lisp_Object debug_print_obj) 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; } @@ -1542,7 +1800,6 @@ debug_print (Lisp_Object debug_print_obj) { debug_print_no_newline (debug_print_obj); stderr_out ("\n"); - fflush (stderr); } /* Debugging kludge -- unbuffered */ @@ -1567,6 +1824,7 @@ debug_backtrace (void) 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); @@ -1575,13 +1833,13 @@ debug_backtrace (void) 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; @@ -1593,13 +1851,11 @@ debug_short_backtrace (int length) 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)) { @@ -1612,15 +1868,12 @@ debug_short_backtrace (int length) if (!NILP (ann)) { stderr_out (""); - fflush (stderr); } else { stderr_out (""); - fflush (stderr); } } else @@ -1630,7 +1883,6 @@ debug_short_backtrace (int length) bt = bt->next; } stderr_out ("]\n"); - fflush (stderr); } #endif /* debugging kludge */ @@ -1660,6 +1912,10 @@ syms_of_print (void) 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); }