Mercurial > hg > xemacs-beta

comparison src/print.c @ 398:74fd4e045ea6 r21-2-29

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-29
author cvs
date Mon, 13 Aug 2007 11:13:30 +0200
parents 6719134a07c2
children 2f8bb876ab1d
comparison
equal deleted inserted replaced
397:f4aeb21a5bad 398:74fd4e045ea6
49 Lisp_Object Vstandard_output, Qstandard_output; 49 Lisp_Object Vstandard_output, Qstandard_output;
50 50
51 /* The subroutine object for external-debugging-output is kept here 51 /* The subroutine object for external-debugging-output is kept here
52 for the convenience of the debugger. */ 52 for the convenience of the debugger. */
53 Lisp_Object Qexternal_debugging_output; 53 Lisp_Object Qexternal_debugging_output;
54 Lisp_Object Qalternate_debugging_output;
55 54
56 /* Avoid actual stack overflow in print. */ 55 /* Avoid actual stack overflow in print. */
57 static int print_depth; 56 static int print_depth;
58 57
59 /* Detect most circularities to print finite output. */ 58 /* Detect most circularities to print finite output. */
60 #define PRINT_CIRCLE 200 59 #define PRINT_CIRCLE 200
61 Lisp_Object being_printed[PRINT_CIRCLE]; 60 static Lisp_Object being_printed[PRINT_CIRCLE];
62 61
63 /* Maximum length of list or vector to print in full; noninteger means 62 /* Maximum length of list or vector to print in full; noninteger means
64 effectively infinity */ 63 effectively infinity */
65 64
66 Lisp_Object Vprint_length; 65 Lisp_Object Vprint_length;
90 Neither t nor nil means so that and don't clear Vprint_gensym_alist 89 Neither t nor nil means so that and don't clear Vprint_gensym_alist
91 on entry to and exit from print functions. */ 90 on entry to and exit from print functions. */
92 Lisp_Object Vprint_gensym; 91 Lisp_Object Vprint_gensym;
93 Lisp_Object Vprint_gensym_alist; 92 Lisp_Object Vprint_gensym_alist;
94 93
95 Lisp_Object Qprint_escape_newlines;
96 Lisp_Object Qprint_readably;
97
98 Lisp_Object Qdisplay_error; 94 Lisp_Object Qdisplay_error;
99 Lisp_Object Qprint_message_label; 95 Lisp_Object Qprint_message_label;
100 96
101 /* Force immediate output of all printed data. Used for debugging. */ 97 /* Force immediate output of all printed data. Used for debugging. */
102 int print_unbuffered; 98 int print_unbuffered;
109 105
110 /* Write a string (in internal format) to stdio stream STREAM. */ 106 /* Write a string (in internal format) to stdio stream STREAM. */
111 107
112 void 108 void
113 write_string_to_stdio_stream (FILE *stream, struct console *con, 109 write_string_to_stdio_stream (FILE *stream, struct console *con,
114 CONST Bufbyte *str, 110 const Bufbyte *str,
115 Bytecount offset, Bytecount len, 111 Bytecount offset, Bytecount len,
116 enum external_data_format fmt) 112 Lisp_Object coding_system)
117 { 113 {
118 int extlen; 114 Extcount extlen;
119 CONST Extbyte *extptr; 115 const Extbyte *extptr;
120 116
121 GET_CHARPTR_EXT_DATA_ALLOCA (str + offset, len, fmt, extptr, extlen); 117 TO_EXTERNAL_FORMAT (DATA, (str + offset, len),
118 ALLOCA, (extptr, extlen),
119 coding_system);
122 if (stream) 120 if (stream)
123 { 121 {
124 fwrite (extptr, 1, extlen, stream); 122 fwrite (extptr, 1, extlen, stream);
125 #ifdef WINDOWSNT 123 #ifdef WINDOWSNT
126 /* Q122442 says that pipes are "treated as files, not as 124 /* Q122442 says that pipes are "treated as files, not as
152 /* Write a string to the output location specified in FUNCTION. 150 /* Write a string to the output location specified in FUNCTION.
153 Arguments NONRELOC, RELOC, OFFSET, and LEN are as in 151 Arguments NONRELOC, RELOC, OFFSET, and LEN are as in
154 buffer_insert_string_1() in insdel.c. */ 152 buffer_insert_string_1() in insdel.c. */
155 153
156 static void 154 static void
157 output_string (Lisp_Object function, CONST Bufbyte *nonreloc, 155 output_string (Lisp_Object function, const Bufbyte *nonreloc,
158 Lisp_Object reloc, Bytecount offset, Bytecount len) 156 Lisp_Object reloc, Bytecount offset, Bytecount len)
159 { 157 {
160 /* This function can GC */ 158 /* This function can GC */
161 Charcount cclen; 159 Charcount cclen;
162 /* We change the value of nonreloc (fetching it from reloc as 160 /* We change the value of nonreloc (fetching it from reloc as
163 necessary), but we don't want to pass this changed value on to 161 necessary), but we don't want to pass this changed value on to
164 other functions that take both a nonreloc and a reloc, or things 162 other functions that take both a nonreloc and a reloc, or things
165 may get confused and an assertion failure in 163 may get confused and an assertion failure in
166 fixup_internal_substring() may get triggered. */ 164 fixup_internal_substring() may get triggered. */
167 CONST Bufbyte *newnonreloc = nonreloc; 165 const Bufbyte *newnonreloc = nonreloc;
168 struct gcpro gcpro1, gcpro2; 166 struct gcpro gcpro1, gcpro2;
169 167
170 /* Emacs won't print while GCing, but an external debugger might */ 168 /* Emacs won't print while GCing, but an external debugger might */
171 if (gc_in_progress) return; 169 if (gc_in_progress) return;
172 170
238 echo_area_append (f, nonreloc, reloc, offset, len, Vprint_message_label); 236 echo_area_append (f, nonreloc, reloc, offset, len, Vprint_message_label);
239 } 237 }
240 else if (EQ (function, Qt) || EQ (function, Qnil)) 238 else if (EQ (function, Qt) || EQ (function, Qnil))
241 { 239 {
242 write_string_to_stdio_stream (stdout, 0, newnonreloc, offset, len, 240 write_string_to_stdio_stream (stdout, 0, newnonreloc, offset, len,
243 FORMAT_TERMINAL); 241 Qterminal);
244 } 242 }
245 else 243 else
246 { 244 {
247 Charcount ccoff = bytecount_to_charcount (newnonreloc, offset); 245 Charcount ccoff = bytecount_to_charcount (newnonreloc, offset);
248 Charcount iii; 246 Charcount iii;
347 } 345 }
348 } 346 }
349 347
350 /* Used for printing a single-byte character (*not* any Emchar). */ 348 /* Used for printing a single-byte character (*not* any Emchar). */
351 #define write_char_internal(string_of_length_1, stream) \ 349 #define write_char_internal(string_of_length_1, stream) \
352 output_string (stream, (CONST Bufbyte *) (string_of_length_1), \ 350 output_string (stream, (const Bufbyte *) (string_of_length_1), \
353 Qnil, 0, 1) 351 Qnil, 0, 1)
354 352
355 /* NOTE: Do not call this with the data of a Lisp_String, as 353 /* NOTE: Do not call this with the data of a Lisp_String, as
356 printcharfun might cause a GC, which might cause the string's data 354 printcharfun might cause a GC, which might cause the string's data
357 to be relocated. To princ a Lisp string, use: 355 to be relocated. To princ a Lisp string, use:
360 358
361 Also note that STREAM should be the result of 359 Also note that STREAM should be the result of
362 canonicalize_printcharfun() (i.e. Qnil means stdout, not 360 canonicalize_printcharfun() (i.e. Qnil means stdout, not
363 Vstandard_output, etc.) */ 361 Vstandard_output, etc.) */
364 void 362 void
365 write_string_1 (CONST Bufbyte *str, Bytecount size, Lisp_Object stream) 363 write_string_1 (const Bufbyte *str, Bytecount size, Lisp_Object stream)
366 { 364 {
367 /* This function can GC */ 365 /* This function can GC */
368 #ifdef ERROR_CHECK_BUFPOS 366 #ifdef ERROR_CHECK_BUFPOS
369 assert (size >= 0); 367 assert (size >= 0);
370 #endif 368 #endif
371 output_string (stream, str, Qnil, 0, size); 369 output_string (stream, str, Qnil, 0, size);
372 } 370 }
373 371
374 void 372 void
375 write_c_string (CONST char *str, Lisp_Object stream) 373 write_c_string (const char *str, Lisp_Object stream)
376 { 374 {
377 /* This function can GC */ 375 /* This function can GC */
378 write_string_1 ((CONST Bufbyte *) str, strlen (str), stream); 376 write_string_1 ((const Bufbyte *) str, strlen (str), stream);
379 } 377 }
380 378
381 379
382 DEFUN ("write-char", Fwrite_char, 1, 2, 0, /* 380 DEFUN ("write-char", Fwrite_char, 1, 2, 0, /*
383 Output character CH to stream STREAM. 381 Output character CH to stream STREAM.
629 } 627 }
630 /* Default method */ 628 /* Default method */
631 { 629 {
632 int first = 1; 630 int first = 1;
633 int speccount = specpdl_depth (); 631 int speccount = specpdl_depth ();
632 Lisp_Object frame = Qnil;
633 struct gcpro gcpro1;
634 GCPRO1 (stream);
634 635
635 specbind (Qprint_message_label, Qerror); 636 specbind (Qprint_message_label, Qerror);
637 stream = print_prepare (stream, &frame);
638
636 tail = Fcdr (error_object); 639 tail = Fcdr (error_object);
637 if (EQ (type, Qerror)) 640 if (EQ (type, Qerror))
638 { 641 {
639 print_internal (Fcar (tail), stream, 0); 642 print_internal (Fcar (tail), stream, 0);
640 tail = Fcdr (tail); 643 tail = Fcdr (tail);
652 write_c_string (first ? ": " : ", ", stream); 655 write_c_string (first ? ": " : ", ", stream);
653 print_internal (Fcar (tail), stream, 1); 656 print_internal (Fcar (tail), stream, 1);
654 tail = Fcdr (tail); 657 tail = Fcdr (tail);
655 first = 0; 658 first = 0;
656 } 659 }
660 print_finish (stream, frame);
661 UNGCPRO;
657 unbind_to (speccount, Qnil); 662 unbind_to (speccount, Qnil);
658 return; 663 return;
659 /* not reached */ 664 /* not reached */
660 } 665 }
661 666
709 714
710 715
711 #ifdef LISP_FLOAT_TYPE 716 #ifdef LISP_FLOAT_TYPE
712 717
713 Lisp_Object Vfloat_output_format; 718 Lisp_Object Vfloat_output_format;
714 Lisp_Object Qfloat_output_format;
715 719
716 /* 720 /*
717 * This buffer should be at least as large as the max string size of the 721 * This buffer should be at least as large as the max string size of the
718 * largest float, printed in the biggest notation. This is undoubtably 722 * largest float, printed in the biggest notation. This is undoubtedly
719 * 20d float_output_format, with the negative of the C-constant "HUGE" 723 * 20d float_output_format, with the negative of the C-constant "HUGE"
720 * from <math.h>. 724 * from <math.h>.
721 * 725 *
722 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes. 726 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
723 * 727 *
804 order (the least significant digit first), and are then reversed. 808 order (the least significant digit first), and are then reversed.
805 This is equivalent to sprintf(buffer, "%ld", number), only much 809 This is equivalent to sprintf(buffer, "%ld", number), only much
806 faster. 810 faster.
807 811
808 BUFFER should accept 24 bytes. This should suffice for the longest 812 BUFFER should accept 24 bytes. This should suffice for the longest
809 numbers on 64-bit machines. */ 813 numbers on 64-bit machines, including the `-' sign and the trailing
814 \0. */
810 void 815 void
811 long_to_string (char *buffer, long number) 816 long_to_string (char *buffer, long number)
812 { 817 {
813 char *p; 818 #if (SIZEOF_LONG != 4) && (SIZEOF_LONG != 8)
814 int i, len; 819 /* Huh? */
820 sprintf (buffer, "%ld", number);
821 #else /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
822 char *p = buffer;
823 int force = 0;
815 824
816 if (number < 0) 825 if (number < 0)
817 { 826 {
818 *buffer++ = '-'; 827 *p++ = '-';
819 number = -number; 828 number = -number;
820 } 829 }
821 p = buffer; 830
822 831 #define FROB(figure) do { \
823 /* Print the digits to the string. */ 832 if (force || number >= figure) \
824 do 833 *p++ = number / figure + '0', number %= figure, force = 1; \
825 { 834 } while (0)
826 *p++ = number % 10 + '0'; 835 #if SIZEOF_LONG == 8
827 number /= 10; 836 FROB (1000000000000000000L);
828 } 837 FROB (100000000000000000L);
829 while (number); 838 FROB (10000000000000000L);
830 839 FROB (1000000000000000L);
831 /* And reverse them. */ 840 FROB (100000000000000L);
832 len = p - buffer - 1; 841 FROB (10000000000000L);
833 for (i = len / 2; i >= 0; i--) 842 FROB (1000000000000L);
834 { 843 FROB (100000000000L);
835 char c = buffer[i]; 844 FROB (10000000000L);
836 buffer[i] = buffer[len - i]; 845 #endif /* SIZEOF_LONG == 8 */
837 buffer[len - i] = c; 846 FROB (1000000000);
838 } 847 FROB (100000000);
839 buffer[len + 1] = '\0'; 848 FROB (10000000);
849 FROB (1000000);
850 FROB (100000);
851 FROB (10000);
852 FROB (1000);
853 FROB (100);
854 FROB (10);
855 #undef FROB
856 *p++ = number + '0';
857 *p = '\0';
858 #endif /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
840 } 859 }
841 860
842 static void 861 static void
843 print_vector_internal (CONST char *start, CONST char *end, 862 print_vector_internal (const char *start, const char *end,
844 Lisp_Object obj, 863 Lisp_Object obj,
845 Lisp_Object printcharfun, int escapeflag) 864 Lisp_Object printcharfun, int escapeflag)
846 { 865 {
847 /* This function can GC */ 866 /* This function can GC */
848 int i; 867 int i;
945 } 964 }
946 965
947 void 966 void
948 print_string (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 967 print_string (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
949 { 968 {
950 struct Lisp_String *s = XSTRING (obj); 969 Lisp_String *s = XSTRING (obj);
951 /* We distinguish between Bytecounts and Charcounts, to make 970 /* We distinguish between Bytecounts and Charcounts, to make
952 Vprint_string_length work correctly under Mule. */ 971 Vprint_string_length work correctly under Mule. */
953 Charcount size = string_char_length (s); 972 Charcount size = string_char_length (s);
954 Charcount max = size; 973 Charcount max = size;
955 Bytecount bcmax = string_length (s); 974 Bytecount bcmax = string_length (s);
1091 if (print_depth > PRINT_CIRCLE) 1110 if (print_depth > PRINT_CIRCLE)
1092 error ("Apparently circular structure being printed"); 1111 error ("Apparently circular structure being printed");
1093 1112
1094 switch (XTYPE (obj)) 1113 switch (XTYPE (obj))
1095 { 1114 {
1096 #ifdef USE_MINIMAL_TAGBITS
1097 case Lisp_Type_Int_Even: 1115 case Lisp_Type_Int_Even:
1098 case Lisp_Type_Int_Odd: 1116 case Lisp_Type_Int_Odd:
1099 #else
1100 case Lisp_Type_Int:
1101 #endif
1102 { 1117 {
1103 char buf[24]; 1118 /* ASCII Decimal representation uses 2.4 times as many bits as
1119 machine binary. */
1120 char buf[3 * sizeof (EMACS_INT) + 5];
1104 long_to_string (buf, XINT (obj)); 1121 long_to_string (buf, XINT (obj));
1105 write_c_string (buf, printcharfun); 1122 write_c_string (buf, printcharfun);
1106 break; 1123 break;
1107 } 1124 }
1108 1125
1111 /* God intended that this be #\..., you know. */ 1128 /* God intended that this be #\..., you know. */
1112 char buf[16]; 1129 char buf[16];
1113 Emchar ch = XCHAR (obj); 1130 Emchar ch = XCHAR (obj);
1114 char *p = buf; 1131 char *p = buf;
1115 *p++ = '?'; 1132 *p++ = '?';
1116 if (ch == '\n') 1133 if (ch < 32)
1117 *p++ = '\\', *p++ = 'n'; 1134 {
1118 else if (ch == '\r') 1135 *p++ = '\\';
1119 *p++ = '\\', *p++ = 'r'; 1136 switch (ch)
1120 else if (ch == '\t') 1137 {
1121 *p++ = '\\', *p++ = 't'; 1138 case '\t': *p++ = 't'; break;
1122 else if (ch < 32) 1139 case '\n': *p++ = 'n'; break;
1140 case '\r': *p++ = 'r'; break;
1141 default:
1142 *p++ = '^';
1143 *p++ = ch + 64;
1144 if ((ch + 64) == '\\')
1145 *p++ = '\\';
1146 break;
1147 }
1148 }
1149 else if (ch < 127)
1150 {
1151 /* syntactically special characters should be escaped. */
1152 switch (ch)
1153 {
1154 case ' ':
1155 case '"':
1156 case '#':
1157 case '\'':
1158 case '(':
1159 case ')':
1160 case ',':
1161 case '.':
1162 case ';':
1163 case '?':
1164 case '[':
1165 case '\\':
1166 case ']':
1167 case '`':
1168 *p++ = '\\';
1169 }
1170 *p++ = ch;
1171 }
1172 else if (ch == 127)
1173 {
1174 *p++ = '\\', *p++ = '^', *p++ = '?';
1175 }
1176 else if (ch < 160)
1123 { 1177 {
1124 *p++ = '\\', *p++ = '^'; 1178 *p++ = '\\', *p++ = '^';
1125 *p++ = ch + 64; 1179 p += set_charptr_emchar ((Bufbyte *) p, ch + 64);
1126 if ((ch + 64) == '\\')
1127 *p++ = '\\';
1128 } 1180 }
1129 else if (ch == 127) 1181 else
1130 *p++ = '\\', *p++ = '^', *p++ = '?';
1131 else if (ch >= 128 && ch < 160)
1132 { 1182 {
1133 *p++ = '\\', *p++ = '^'; 1183 p += set_charptr_emchar ((Bufbyte *) p, ch);
1134 p += set_charptr_emchar ((Bufbyte *)p, ch + 64);
1135 } 1184 }
1136 else if (ch < 127 1185
1137 && !isdigit (ch) 1186 output_string (printcharfun, (Bufbyte *) buf, Qnil, 0, p - buf);
1138 && !isalpha (ch) 1187
1139 && ch != '^') /* must not backslash this or it will
1140 be interpreted as the start of a
1141 control char */
1142 *p++ = '\\', *p++ = ch;
1143 else
1144 p += set_charptr_emchar ((Bufbyte *)p, ch);
1145 output_string (printcharfun, (Bufbyte *)buf, Qnil, 0, p - buf);
1146 break; 1188 break;
1147 } 1189 }
1148
1149 #ifndef LRECORD_STRING
1150 case Lisp_Type_String:
1151 {
1152 print_string (obj, printcharfun, escapeflag);
1153 break;
1154 }
1155 #endif /* ! LRECORD_STRING */
1156
1157 #ifndef LRECORD_CONS
1158 case Lisp_Type_Cons:
1159 {
1160 struct gcpro gcpro1, gcpro2;
1161
1162 /* If deeper than spec'd depth, print placeholder. */
1163 if (INTP (Vprint_level)
1164 && print_depth > XINT (Vprint_level))
1165 {
1166 GCPRO2 (obj, printcharfun);
1167 write_c_string ("...", printcharfun);
1168 UNGCPRO;
1169 break;
1170 }
1171
1172 print_cons (obj, printcharfun, escapeflag);
1173 break;
1174 }
1175 #endif /* ! LRECORD_CONS */
1176
1177 #ifndef LRECORD_VECTOR
1178 case Lisp_Type_Vector:
1179 {
1180 /* If deeper than spec'd depth, print placeholder. */
1181 if (INTP (Vprint_level)
1182 && print_depth > XINT (Vprint_level))
1183 {
1184 struct gcpro gcpro1, gcpro2;
1185 GCPRO2 (obj, printcharfun);
1186 write_c_string ("...", printcharfun);
1187 UNGCPRO;
1188 break;
1189 }
1190
1191 /* God intended that this be #(...), you know. */
1192 print_vector_internal ("[", "]", obj, printcharfun, escapeflag);
1193 break;
1194 }
1195 #endif /* !LRECORD_VECTOR */
1196
1197 #ifndef LRECORD_SYMBOL
1198 case Lisp_Type_Symbol:
1199 {
1200 print_symbol (obj, printcharfun, escapeflag);
1201 break;
1202 }
1203 #endif /* !LRECORD_SYMBOL */
1204 1190
1205 case Lisp_Type_Record: 1191 case Lisp_Type_Record:
1206 { 1192 {
1207 struct lrecord_header *lheader = XRECORD_LHEADER (obj); 1193 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
1208 struct gcpro gcpro1, gcpro2; 1194 struct gcpro gcpro1, gcpro2;
1209 1195
1210 #if defined(LRECORD_CONS) || defined(LRECORD_VECTOR)
1211 if (CONSP (obj) || VECTORP(obj)) 1196 if (CONSP (obj) || VECTORP(obj))
1212 { 1197 {
1213 /* If deeper than spec'd depth, print placeholder. */ 1198 /* If deeper than spec'd depth, print placeholder. */
1214 if (INTP (Vprint_level) 1199 if (INTP (Vprint_level)
1215 && print_depth > XINT (Vprint_level)) 1200 && print_depth > XINT (Vprint_level))
1218 write_c_string ("...", printcharfun); 1203 write_c_string ("...", printcharfun);
1219 UNGCPRO; 1204 UNGCPRO;
1220 break; 1205 break;
1221 } 1206 }
1222 } 1207 }
1223 #endif
1224 1208
1225 GCPRO2 (obj, printcharfun); 1209 GCPRO2 (obj, printcharfun);
1226 if (LHEADER_IMPLEMENTATION (lheader)->printer) 1210 if (LHEADER_IMPLEMENTATION (lheader)->printer)
1227 ((LHEADER_IMPLEMENTATION (lheader)->printer) 1211 ((LHEADER_IMPLEMENTATION (lheader)->printer)
1228 (obj, printcharfun, escapeflag)); 1212 (obj, printcharfun, escapeflag));
1273 print_symbol (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 1257 print_symbol (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1274 { 1258 {
1275 /* This function can GC */ 1259 /* This function can GC */
1276 /* #### Bug!! (intern "") isn't printed in some distinguished way */ 1260 /* #### Bug!! (intern "") isn't printed in some distinguished way */
1277 /* #### (the reader also loses on it) */ 1261 /* #### (the reader also loses on it) */
1278 struct Lisp_String *name = symbol_name (XSYMBOL (obj)); 1262 Lisp_String *name = symbol_name (XSYMBOL (obj));
1279 Bytecount size = string_length (name); 1263 Bytecount size = string_length (name);
1280 struct gcpro gcpro1, gcpro2; 1264 struct gcpro gcpro1, gcpro2;
1281 1265
1282 if (!escapeflag) 1266 if (!escapeflag)
1283 { 1267 {
1290 GCPRO2 (obj, printcharfun); 1274 GCPRO2 (obj, printcharfun);
1291 1275
1292 /* If we print an uninterned symbol as part of a complex object and 1276 /* If we print an uninterned symbol as part of a complex object and
1293 the flag print-gensym is non-nil, prefix it with #n= to read the 1277 the flag print-gensym is non-nil, prefix it with #n= to read the
1294 object back with the #n# reader syntax later if needed. */ 1278 object back with the #n# reader syntax later if needed. */
1295 if (!NILP (Vprint_gensym) && NILP (XSYMBOL (obj)->obarray)) 1279 if (!NILP (Vprint_gensym)
1280 /* #### Test whether this produces a noticable slow-down for
1281 printing when print-gensym is non-nil. */
1282 && !EQ (obj, oblookup (Vobarray,
1283 string_data (symbol_name (XSYMBOL (obj))),
1284 string_length (symbol_name (XSYMBOL (obj))))))
1296 { 1285 {
1297 if (print_depth > 1) 1286 if (print_depth > 1)
1298 { 1287 {
1299 Lisp_Object tem = Fassq (obj, Vprint_gensym_alist); 1288 Lisp_Object tem = Fassq (obj, Vprint_gensym_alist);
1300 if (CONSP (tem)) 1289 if (CONSP (tem))
1402 alternate-debugging-output @ 429542' -slb */ 1391 alternate-debugging-output @ 429542' -slb */
1403 /* #### Eek! Any clue how to get rid of it? In fact, how about 1392 /* #### Eek! Any clue how to get rid of it? In fact, how about
1404 getting rid of this function altogether? Does anything actually 1393 getting rid of this function altogether? Does anything actually
1405 *use* it? --hniksic */ 1394 *use* it? --hniksic */
1406 1395
1407 int alternate_do_pointer; 1396 static int alternate_do_pointer;
1408 char alternate_do_string[5000]; 1397 static char alternate_do_string[5000];
1409 1398
1410 DEFUN ("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0, /* 1399 DEFUN ("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0, /*
1411 Append CHARACTER to the array `alternate_do_string'. 1400 Append CHARACTER to the array `alternate_do_string'.
1412 This can be used in place of `external-debugging-output' as a function 1401 This can be used in place of `external-debugging-output' as a function
1413 to be passed to `print'. Before calling `print', set `alternate_do_pointer' 1402 to be passed to `print'. Before calling `print', set `alternate_do_pointer'
1416 (character)) 1405 (character))
1417 { 1406 {
1418 Bufbyte str[MAX_EMCHAR_LEN]; 1407 Bufbyte str[MAX_EMCHAR_LEN];
1419 Bytecount len; 1408 Bytecount len;
1420 int extlen; 1409 int extlen;
1421 CONST Extbyte *extptr; 1410 const Extbyte *extptr;
1422 1411
1423 CHECK_CHAR_COERCE_INT (character); 1412 CHECK_CHAR_COERCE_INT (character);
1424 len = set_charptr_emchar (str, XCHAR (character)); 1413 len = set_charptr_emchar (str, XCHAR (character));
1425 GET_CHARPTR_EXT_DATA_ALLOCA (str, len, FORMAT_TERMINAL, extptr, extlen); 1414 TO_EXTERNAL_FORMAT (DATA, (str, len),
1415 ALLOCA, (extptr, extlen),
1416 Qterminal);
1426 memcpy (alternate_do_string + alternate_do_pointer, extptr, extlen); 1417 memcpy (alternate_do_string + alternate_do_pointer, extptr, extlen);
1427 alternate_do_pointer += extlen; 1418 alternate_do_pointer += extlen;
1428 alternate_do_string[alternate_do_pointer] = 0; 1419 alternate_do_string[alternate_do_pointer] = 0;
1429 return character; 1420 return character;
1430 } 1421 }
1468 1459
1469 if (STRINGP (char_or_string)) 1460 if (STRINGP (char_or_string))
1470 write_string_to_stdio_stream (file, con, 1461 write_string_to_stdio_stream (file, con,
1471 XSTRING_DATA (char_or_string), 1462 XSTRING_DATA (char_or_string),
1472 0, XSTRING_LENGTH (char_or_string), 1463 0, XSTRING_LENGTH (char_or_string),
1473 FORMAT_TERMINAL); 1464 Qterminal);
1474 else 1465 else
1475 { 1466 {
1476 Bufbyte str[MAX_EMCHAR_LEN]; 1467 Bufbyte str[MAX_EMCHAR_LEN];
1477 Bytecount len; 1468 Bytecount len;
1478 1469
1479 CHECK_CHAR_COERCE_INT (char_or_string); 1470 CHECK_CHAR_COERCE_INT (char_or_string);
1480 len = set_charptr_emchar (str, XCHAR (char_or_string)); 1471 len = set_charptr_emchar (str, XCHAR (char_or_string));
1481 write_string_to_stdio_stream (file, con, str, 0, len, FORMAT_TERMINAL); 1472 write_string_to_stdio_stream (file, con, str, 0, len, Qterminal);
1482 } 1473 }
1483 1474
1484 return char_or_string; 1475 return char_or_string;
1485 } 1476 }
1486 1477
1505 return Qnil; 1496 return Qnil;
1506 } 1497 }
1507 1498
1508 #if 1 1499 #if 1
1509 /* Debugging kludge -- unbuffered */ 1500 /* Debugging kludge -- unbuffered */
1510 static int debug_print_length = 50; 1501 static int debug_print_length = 50;
1511 static int debug_print_level = 15; 1502 static int debug_print_level = 15;
1512 Lisp_Object debug_temp; 1503 static int debug_print_readably = -1;
1513 1504
1514 static void 1505 static void
1515 debug_print_no_newline (Lisp_Object debug_print_obj) 1506 debug_print_no_newline (Lisp_Object debug_print_obj)
1516 { 1507 {
1517 /* This function can GC */ 1508 /* This function can GC */
1518 int old_print_readably = print_readably; 1509 int save_print_readably = print_readably;
1519 int old_print_depth = print_depth; 1510 int save_print_depth = print_depth;
1520 Lisp_Object old_print_length = Vprint_length; 1511 Lisp_Object save_Vprint_length = Vprint_length;
1521 Lisp_Object old_print_level = Vprint_level; 1512 Lisp_Object save_Vprint_level = Vprint_level;
1522 Lisp_Object old_inhibit_quit = Vinhibit_quit; 1513 Lisp_Object save_Vinhibit_quit = Vinhibit_quit;
1523 struct gcpro gcpro1, gcpro2, gcpro3; 1514 struct gcpro gcpro1, gcpro2, gcpro3;
1524 GCPRO3 (old_print_level, old_print_length, old_inhibit_quit); 1515 GCPRO3 (save_Vprint_level, save_Vprint_length, save_Vinhibit_quit);
1525 1516
1526 if (gc_in_progress) 1517 if (gc_in_progress)
1527 stderr_out ("** gc-in-progress! Bad idea to print anything! **\n"); 1518 stderr_out ("** gc-in-progress! Bad idea to print anything! **\n");
1528 1519
1529 print_depth = 0; 1520 print_depth = 0;
1530 print_readably = 0; 1521 print_readably = debug_print_readably != -1 ? debug_print_readably : 0;
1531 print_unbuffered++; 1522 print_unbuffered++;
1532 /* Could use unwind-protect, but why bother? */ 1523 /* Could use unwind-protect, but why bother? */
1533 if (debug_print_length > 0) 1524 if (debug_print_length > 0)
1534 Vprint_length = make_int (debug_print_length); 1525 Vprint_length = make_int (debug_print_length);
1535 if (debug_print_level > 0) 1526 if (debug_print_level > 0)
1536 Vprint_level = make_int (debug_print_level); 1527 Vprint_level = make_int (debug_print_level);
1528
1537 print_internal (debug_print_obj, Qexternal_debugging_output, 1); 1529 print_internal (debug_print_obj, Qexternal_debugging_output, 1);
1538 Vinhibit_quit = old_inhibit_quit; 1530
1539 Vprint_level = old_print_level; 1531 Vinhibit_quit = save_Vinhibit_quit;
1540 Vprint_length = old_print_length; 1532 Vprint_level = save_Vprint_level;
1541 print_depth = old_print_depth; 1533 Vprint_length = save_Vprint_length;
1542 print_readably = old_print_readably; 1534 print_depth = save_print_depth;
1535 print_readably = save_print_readably;
1543 print_unbuffered--; 1536 print_unbuffered--;
1544 UNGCPRO; 1537 UNGCPRO;
1545 } 1538 }
1546 1539
1547 void 1540 void
1644 1637
1645 1638
1646 void 1639 void
1647 syms_of_print (void) 1640 syms_of_print (void)
1648 { 1641 {
1649 defsymbol (&Qprint_escape_newlines, "print-escape-newlines");
1650 defsymbol (&Qprint_readably, "print-readably");
1651
1652 defsymbol (&Qstandard_output, "standard-output"); 1642 defsymbol (&Qstandard_output, "standard-output");
1653
1654 #ifdef LISP_FLOAT_TYPE
1655 defsymbol (&Qfloat_output_format, "float-output-format");
1656 #endif
1657 1643
1658 defsymbol (&Qprint_length, "print-length"); 1644 defsymbol (&Qprint_length, "print-length");
1659 1645
1660 defsymbol (&Qprint_string_length, "print-string-length"); 1646 defsymbol (&Qprint_string_length, "print-string-length");
1661 1647
1669 DEFSUBR (Ferror_message_string); 1655 DEFSUBR (Ferror_message_string);
1670 DEFSUBR (Fdisplay_error); 1656 DEFSUBR (Fdisplay_error);
1671 DEFSUBR (Fterpri); 1657 DEFSUBR (Fterpri);
1672 DEFSUBR (Fwrite_char); 1658 DEFSUBR (Fwrite_char);
1673 DEFSUBR (Falternate_debugging_output); 1659 DEFSUBR (Falternate_debugging_output);
1674 defsymbol (&Qalternate_debugging_output, "alternate-debugging-output");
1675 DEFSUBR (Fexternal_debugging_output); 1660 DEFSUBR (Fexternal_debugging_output);
1676 DEFSUBR (Fopen_termscript); 1661 DEFSUBR (Fopen_termscript);
1677 defsymbol (&Qexternal_debugging_output, "external-debugging-output"); 1662 defsymbol (&Qexternal_debugging_output, "external-debugging-output");
1678 DEFSUBR (Fwith_output_to_temp_buffer); 1663 DEFSUBR (Fwith_output_to_temp_buffer);
1679 } 1664 }
1680 1665
1681 void 1666 void
1667 reinit_vars_of_print (void)
1668 {
1669 alternate_do_pointer = 0;
1670 }
1671
1672 void
1682 vars_of_print (void) 1673 vars_of_print (void)
1683 { 1674 {
1684 alternate_do_pointer = 0; 1675 reinit_vars_of_print ();
1685 1676
1686 DEFVAR_LISP ("standard-output", &Vstandard_output /* 1677 DEFVAR_LISP ("standard-output", &Vstandard_output /*
1687 Output stream `print' uses by default for outputting a character. 1678 Output stream `print' uses by default for outputting a character.
1688 This may be any function of one argument. 1679 This may be any function of one argument.
1689 It may also be a buffer (output is inserted before point) 1680 It may also be a buffer (output is inserted before point)