X-Git-Url: http://git.chise.org/gitweb/?p=chise%2Fxemacs-chise.git.1;a=blobdiff_plain;f=src%2Fprint.c;h=afbbf0d5b83476b57eebe3c1f35bb332c551695a;hp=480cf9c8a4ded852bdd4371345c0779b48ee4654;hb=34360e98c9689b0a7eedab93e14df13281141bbd;hpb=6883ee56ec887c2c48abe5b06b5e66aa74031910 diff --git a/src/print.c b/src/print.c index 480cf9c..afbbf0d 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 Ben Wing. This file is part of XEmacs. @@ -38,6 +38,9 @@ Boston, MA 02111-1307, USA. */ #include "insdel.h" #include "lstream.h" #include "sysfile.h" +#ifdef WIN32_NATIVE +#include "console-msw.h" +#endif #include /* Define if not in float.h */ @@ -49,15 +52,18 @@ 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 Qalternate_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; /* 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 */ @@ -91,9 +97,6 @@ int print_readably; 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; @@ -106,38 +109,45 @@ FILE *termscript; /* Stdio stream being used for copy of all output. */ 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); +#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 - { - 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) { @@ -148,12 +158,132 @@ write_string_to_stdio_stream (FILE *stream, struct console *con, } } +/* #### 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 && !fatal_error_in_progress) + 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, + 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 */ @@ -163,10 +293,10 @@ output_string (Lisp_Object function, CONST Bufbyte *nonreloc, 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. */ @@ -239,7 +369,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, - FORMAT_TERMINAL); + Qterminal, print_unbuffered); } else { @@ -278,7 +408,7 @@ canonicalize_printcharfun (Lisp_Object printcharfun) 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; @@ -323,7 +453,7 @@ print_prepare (Lisp_Object printcharfun, Lisp_Object *frame_kludge) 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; @@ -341,14 +471,14 @@ print_finish (Lisp_Object stream, Lisp_Object frame_kludge) 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); } } /* 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 @@ -361,7 +491,7 @@ print_finish (Lisp_Object stream, Lisp_Object frame_kludge) 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 @@ -371,10 +501,10 @@ write_string_1 (CONST Bufbyte *str, Bytecount size, Lisp_Object stream) } 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); } @@ -395,7 +525,7 @@ STREAM defaults to the value of `standard-output' (which see). } void -temp_output_buffer_setup (CONST char *bufname) +temp_output_buffer_setup (Lisp_Object bufname) { /* This function can GC */ struct buffer *old = current_buffer; @@ -406,7 +536,7 @@ temp_output_buffer_setup (CONST char *bufname) 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); @@ -418,7 +548,7 @@ temp_output_buffer_setup (CONST char *bufname) } 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) @@ -429,7 +559,7 @@ internal_with_output_to_temp_buffer (CONST char *bufname, GCPRO3 (buf, arg, same_frame); - temp_output_buffer_setup (GETTEXT (bufname)); + temp_output_buffer_setup (bufname); buf = Vstandard_output; arg = (*function) (arg); @@ -454,21 +584,22 @@ to get the buffer displayed. It gets one argument, the buffer to display. (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)); @@ -629,8 +760,13 @@ print_error_message (Lisp_Object error_object, Lisp_Object stream) { 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)) { @@ -652,6 +788,8 @@ print_error_message (Lisp_Object error_object, Lisp_Object stream) tail = Fcdr (tail); first = 0; } + print_finish (stream, frame); + UNGCPRO; unbind_to (speccount, Qnil); return; /* not reached */ @@ -709,11 +847,10 @@ Display ERROR-OBJECT on STREAM in a user-friendly way. #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 . * @@ -798,47 +935,60 @@ 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. */ + 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) */ } 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) { @@ -896,23 +1046,33 @@ print_cons (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 ("... ", 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)) @@ -921,6 +1081,7 @@ print_cons (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) print_internal (obj, printcharfun, escapeflag); } UNGCPRO; + write_char_internal (")", printcharfun); return; } @@ -934,7 +1095,7 @@ print_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 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); @@ -1041,7 +1202,7 @@ print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 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 @@ -1080,14 +1241,12 @@ print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 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; @@ -1100,101 +1259,69 @@ print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 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 */ + output_string (printcharfun, (Bufbyte *) buf, Qnil, 0, p - buf); -#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; - } - - /* 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. */ @@ -1207,7 +1334,6 @@ print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) break; } } -#endif GCPRO2 (obj, printcharfun); if (LHEADER_IMPLEMENTATION (lheader)->printer) @@ -1244,79 +1370,6 @@ print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 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) ? "#[" : - "#"), - obj, printcharfun, escapeflag); -} #ifdef LISP_FLOAT_TYPE void @@ -1324,7 +1377,7 @@ print_float (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { 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 */ @@ -1335,7 +1388,7 @@ print_symbol (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) /* 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; @@ -1352,7 +1405,12 @@ print_symbol (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) /* 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 noticeable 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) { @@ -1431,17 +1489,22 @@ print_symbol (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 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; } @@ -1451,16 +1514,12 @@ 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. */ -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'. @@ -1473,17 +1532,18 @@ to 0. 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; return character; } -/* #endif / * DEBUG_XEMACS */ DEFUN ("external-debugging-output", Fexternal_debugging_output, 1, 3, 0, /* Write CHAR-OR-STRING to stderr or stdout. @@ -1491,6 +1551,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. */ @@ -1516,16 +1580,16 @@ 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]; @@ -1533,7 +1597,7 @@ 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, FORMAT_TERMINAL); + write_string_to_stdio_stream (file, con, str, 0, len, Qterminal, 1); } return char_or_string; @@ -1562,39 +1626,47 @@ FILE = nil means just close any termscript file currently open. #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; + 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; print_unbuffered--; UNGCPRO; } @@ -1604,7 +1676,6 @@ debug_print (Lisp_Object debug_print_obj) { debug_print_no_newline (debug_print_obj); stderr_out ("\n"); - fflush (stderr); } /* Debugging kludge -- unbuffered */ @@ -1614,11 +1685,12 @@ void 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); @@ -1633,15 +1705,17 @@ debug_backtrace (void) 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; } @@ -1651,33 +1725,29 @@ 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)) { #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 (""); - fflush (stderr); } else { stderr_out (""); - fflush (stderr); } } else @@ -1687,7 +1757,6 @@ debug_short_backtrace (int length) bt = bt->next; } stderr_out ("]\n"); - fflush (stderr); } #endif /* debugging kludge */ @@ -1696,15 +1765,8 @@ debug_short_backtrace (int length) 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"); @@ -1721,17 +1783,26 @@ syms_of_print (void) 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"); + 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); } 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.