Mercurial > hg > xemacs-beta

comparison src/print.c @ 380:8626e4521993 r21-2-5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-5
author cvs
date Mon, 13 Aug 2007 11:07:10 +0200
parents cc15677e0335
children 6719134a07c2
comparison
equal deleted inserted replaced
379:76b7d63099ad 380:8626e4521993
37 #include "frame.h" 37 #include "frame.h"
38 #include "insdel.h" 38 #include "insdel.h"
39 #include "lstream.h" 39 #include "lstream.h"
40 #include "sysfile.h" 40 #include "sysfile.h"
41 41
42 #include <limits.h>
42 #include <float.h> 43 #include <float.h>
43 /* Define if not in float.h */ 44 /* Define if not in float.h */
44 #ifndef DBL_DIG 45 #ifndef DBL_DIG
45 #define DBL_DIG 16 46 #define DBL_DIG 16
46 #endif 47 #endif
164 may get confused and an assertion failure in 165 may get confused and an assertion failure in
165 fixup_internal_substring() may get triggered. */ 166 fixup_internal_substring() may get triggered. */
166 CONST Bufbyte *newnonreloc = nonreloc; 167 CONST Bufbyte *newnonreloc = nonreloc;
167 struct gcpro gcpro1, gcpro2; 168 struct gcpro gcpro1, gcpro2;
168 169
169 /* Emacs won't print whilst GCing, but an external debugger might */ 170 /* Emacs won't print while GCing, but an external debugger might */
170 if (gc_in_progress) return; 171 if (gc_in_progress) return;
171 172
172 /* Perhaps not necessary but probably safer. */ 173 /* Perhaps not necessary but probably safer. */
173 GCPRO2 (function, reloc); 174 GCPRO2 (function, reloc);
174 175
276 } 277 }
277 278
278 static Lisp_Object 279 static Lisp_Object
279 print_prepare (Lisp_Object printcharfun, Lisp_Object *frame_kludge) 280 print_prepare (Lisp_Object printcharfun, Lisp_Object *frame_kludge)
280 { 281 {
281 /* Emacs won't print whilst GCing, but an external debugger might */ 282 /* Emacs won't print while GCing, but an external debugger might */
282 if (gc_in_progress) 283 if (gc_in_progress)
283 return Qnil; 284 return Qnil;
284 285
285 RESET_PRINT_GENSYM; 286 RESET_PRINT_GENSYM;
286 287
321 } 322 }
322 323
323 static void 324 static void
324 print_finish (Lisp_Object stream, Lisp_Object frame_kludge) 325 print_finish (Lisp_Object stream, Lisp_Object frame_kludge)
325 { 326 {
326 /* Emacs won't print whilst GCing, but an external debugger might */ 327 /* Emacs won't print while GCing, but an external debugger might */
327 if (gc_in_progress) 328 if (gc_in_progress)
328 return; 329 return;
329 330
330 RESET_PRINT_GENSYM; 331 RESET_PRINT_GENSYM;
331 332
339 Lstream_flush (str); 340 Lstream_flush (str);
340 if (!EQ (Vprint_message_label, echo_area_status (f))) 341 if (!EQ (Vprint_message_label, echo_area_status (f)))
341 clear_echo_area_from_print (f, Qnil, 1); 342 clear_echo_area_from_print (f, Qnil, 1);
342 echo_area_append (f, resizing_buffer_stream_ptr (str), 343 echo_area_append (f, resizing_buffer_stream_ptr (str),
343 Qnil, 0, Lstream_byte_count (str), 344 Qnil, 0, Lstream_byte_count (str),
344 Vprint_message_label); 345 Vprint_message_label);
345 Lstream_delete (str); 346 Lstream_delete (str);
346 } 347 }
347 } 348 }
348 349
349 /* Used for printing a single-byte character (*not* any Emchar). */ 350 /* Used for printing a single-byte character (*not* any Emchar). */
393 output_string (canonicalize_printcharfun (stream), str, Qnil, 0, len); 394 output_string (canonicalize_printcharfun (stream), str, Qnil, 0, len);
394 return ch; 395 return ch;
395 } 396 }
396 397
397 void 398 void
398 temp_output_buffer_setup (CONST char *bufname) 399 temp_output_buffer_setup (Lisp_Object bufname)
399 { 400 {
400 /* This function can GC */ 401 /* This function can GC */
401 struct buffer *old = current_buffer; 402 struct buffer *old = current_buffer;
402 Lisp_Object buf; 403 Lisp_Object buf;
403 404
404 #ifdef I18N3 405 #ifdef I18N3
405 /* #### This function should accept a Lisp_Object instead of a char *, 406 /* #### This function should accept a Lisp_Object instead of a char *,
406 so that proper translation on the buffer name can occur. */ 407 so that proper translation on the buffer name can occur. */
407 #endif 408 #endif
408 409
409 Fset_buffer (Fget_buffer_create (build_string (bufname))); 410 Fset_buffer (Fget_buffer_create (bufname));
410 411
411 current_buffer->read_only = Qnil; 412 current_buffer->read_only = Qnil;
412 Ferase_buffer (Qnil); 413 Ferase_buffer (Qnil);
413 414
414 XSETBUFFER (buf, current_buffer); 415 XSETBUFFER (buf, current_buffer);
416 417
417 set_buffer_internal (old); 418 set_buffer_internal (old);
418 } 419 }
419 420
420 Lisp_Object 421 Lisp_Object
421 internal_with_output_to_temp_buffer (CONST char *bufname, 422 internal_with_output_to_temp_buffer (Lisp_Object bufname,
422 Lisp_Object (*function) (Lisp_Object arg), 423 Lisp_Object (*function) (Lisp_Object arg),
423 Lisp_Object arg, 424 Lisp_Object arg,
424 Lisp_Object same_frame) 425 Lisp_Object same_frame)
425 { 426 {
426 int speccount = specpdl_depth (); 427 int speccount = specpdl_depth ();
427 struct gcpro gcpro1, gcpro2, gcpro3; 428 struct gcpro gcpro1, gcpro2, gcpro3;
428 Lisp_Object buf = Qnil; 429 Lisp_Object buf = Qnil;
429 430
430 GCPRO3 (buf, arg, same_frame); 431 GCPRO3 (buf, arg, same_frame);
431 432
432 temp_output_buffer_setup (GETTEXT (bufname)); 433 temp_output_buffer_setup (bufname);
433 buf = Vstandard_output; 434 buf = Vstandard_output;
434 435
435 arg = (*function) (arg); 436 arg = (*function) (arg);
436 437
437 temp_output_buffer_show (buf, same_frame); 438 temp_output_buffer_show (buf, same_frame);
452 to get the buffer displayed. It gets one argument, the buffer to display. 453 to get the buffer displayed. It gets one argument, the buffer to display.
453 */ 454 */
454 (args)) 455 (args))
455 { 456 {
456 /* This function can GC */ 457 /* This function can GC */
457 struct gcpro gcpro1; 458 Lisp_Object name = Qnil;
458 Lisp_Object name;
459 int speccount = specpdl_depth (); 459 int speccount = specpdl_depth ();
460 Lisp_Object val; 460 struct gcpro gcpro1, gcpro2;
461 Lisp_Object val = Qnil;
461 462
462 #ifdef I18N3 463 #ifdef I18N3
463 /* #### should set the buffer to be translating. See print_internal(). */ 464 /* #### should set the buffer to be translating. See print_internal(). */
464 #endif 465 #endif
465 466
466 GCPRO1 (args); 467 GCPRO2 (name, val);
467 name = Feval (XCAR (args)); 468 name = Feval (XCAR (args));
469
470 CHECK_STRING (name);
471
472 temp_output_buffer_setup (name);
468 UNGCPRO; 473 UNGCPRO;
469
470 CHECK_STRING (name);
471 temp_output_buffer_setup ((char *) XSTRING_DATA (name));
472 474
473 val = Fprogn (XCDR (args)); 475 val = Fprogn (XCDR (args));
474 476
475 temp_output_buffer_show (Vstandard_output, Qnil); 477 temp_output_buffer_show (Vstandard_output, Qnil);
476 478
894 896
895 GCPRO2 (obj, printcharfun); 897 GCPRO2 (obj, printcharfun);
896 write_char_internal ("(", printcharfun); 898 write_char_internal ("(", printcharfun);
897 899
898 { 900 {
899 int i = 0; 901 int len;
900 int max = 0; 902 int max = INTP (Vprint_length) ? XINT (Vprint_length) : INT_MAX;
901 903 Lisp_Object tortoise;
902 if (INTP (Vprint_length)) 904 /* Use tortoise/hare to make sure circular lists don't infloop */
903 max = XINT (Vprint_length); 905
904 while (CONSP (obj)) 906 for (tortoise = obj, len = 0;
907 CONSP (obj);
908 obj = XCDR (obj), len++)
905 { 909 {
906 if (i++) 910 if (len > 0)
907 write_char_internal (" ", printcharfun); 911 write_char_internal (" ", printcharfun);
908 if (max && i > max) 912 if (EQ (obj, tortoise) && len > 0)
913 {
914 if (print_readably)
915 error ("printing unreadable circular list");
916 else
917 write_c_string ("... <circular list>", printcharfun);
918 break;
919 }
920 if (len & 1)
921 tortoise = XCDR (tortoise);
922 if (len > max)
909 { 923 {
910 write_c_string ("...", printcharfun); 924 write_c_string ("...", printcharfun);
911 break; 925 break;
912 } 926 }
913 print_internal (XCAR (obj), printcharfun, 927 print_internal (XCAR (obj), printcharfun, escapeflag);
914 escapeflag);
915 obj = XCDR (obj);
916 } 928 }
917 } 929 }
918 if (!LISTP (obj)) 930 if (!LISTP (obj))
919 { 931 {
920 write_c_string (" . ", printcharfun); 932 write_c_string (" . ", printcharfun);
921 print_internal (obj, printcharfun, escapeflag); 933 print_internal (obj, printcharfun, escapeflag);
922 } 934 }
923 UNGCPRO; 935 UNGCPRO;
936
924 write_char_internal (")", printcharfun); 937 write_char_internal (")", printcharfun);
925 return; 938 return;
926 } 939 }
927 940
928 void 941 void
1039 { 1052 {
1040 /* This function can GC */ 1053 /* This function can GC */
1041 1054
1042 QUIT; 1055 QUIT;
1043 1056
1044 /* Emacs won't print whilst GCing, but an external debugger might */ 1057 /* Emacs won't print while GCing, but an external debugger might */
1045 if (gc_in_progress) return; 1058 if (gc_in_progress) return;
1046 1059
1047 #ifdef I18N3 1060 #ifdef I18N3
1048 /* #### Both input and output streams should have a flag associated 1061 /* #### Both input and output streams should have a flag associated
1049 with them indicating whether output to that stream, or strings 1062 with them indicating whether output to that stream, or strings
1242 } 1255 }
1243 1256
1244 print_depth--; 1257 print_depth--;
1245 } 1258 }
1246 1259
1247 static void
1248 print_compiled_function_internal (CONST char *start, CONST char *end,
1249 Lisp_Object obj,
1250 Lisp_Object printcharfun, int escapeflag)
1251 {
1252 /* This function can GC */
1253 struct Lisp_Compiled_Function *b =
1254 XCOMPILED_FUNCTION (obj); /* GC doesn't relocate */
1255 int docp = b->flags.documentationp;
1256 int intp = b->flags.interactivep;
1257 struct gcpro gcpro1, gcpro2;
1258 char buf[100];
1259 GCPRO2 (obj, printcharfun);
1260
1261 write_c_string (start, printcharfun);
1262 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1263 if (!print_readably)
1264 {
1265 Lisp_Object ann = compiled_function_annotation (b);
1266 if (!NILP (ann))
1267 {
1268 write_c_string ("(from ", printcharfun);
1269 print_internal (ann, printcharfun, 1);
1270 write_c_string (") ", printcharfun);
1271 }
1272 }
1273 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1274 /* COMPILED_ARGLIST = 0 */
1275 print_internal (b->arglist, printcharfun, escapeflag);
1276 /* COMPILED_BYTECODE = 1 */
1277 write_char_internal (" ", printcharfun);
1278 /* we don't really want to see that junk in the bytecode instructions. */
1279 if (STRINGP (b->bytecodes) && !print_readably)
1280 {
1281 sprintf (buf, "\"...(%ld)\"", (long) XSTRING_LENGTH (b->bytecodes));
1282 write_c_string (buf, printcharfun);
1283 }
1284 else
1285 print_internal (b->bytecodes, printcharfun, escapeflag);
1286 /* COMPILED_CONSTANTS = 2 */
1287 write_char_internal (" ", printcharfun);
1288 print_internal (b->constants, printcharfun, escapeflag);
1289 /* COMPILED_STACK_DEPTH = 3 */
1290 sprintf (buf, " %d", b->maxdepth);
1291 write_c_string (buf, printcharfun);
1292 /* COMPILED_DOC_STRING = 4 */
1293 if (docp || intp)
1294 {
1295 write_char_internal (" ", printcharfun);
1296 print_internal (compiled_function_documentation (b), printcharfun,
1297 escapeflag);
1298 }
1299 /* COMPILED_INTERACTIVE = 5 */
1300 if (intp)
1301 {
1302 write_char_internal (" ", printcharfun);
1303 print_internal (compiled_function_interactive (b), printcharfun,
1304 escapeflag);
1305 }
1306 UNGCPRO;
1307 write_c_string (end, printcharfun);
1308 }
1309
1310 void
1311 print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun,
1312 int escapeflag)
1313 {
1314 /* This function can GC */
1315 print_compiled_function_internal (((print_readably) ? "#[" :
1316 "#<compiled-function "),
1317 ((print_readably) ? "]" : ">"),
1318 obj, printcharfun, escapeflag);
1319 }
1320 1260
1321 #ifdef LISP_FLOAT_TYPE 1261 #ifdef LISP_FLOAT_TYPE
1322 void 1262 void
1323 print_float (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 1263 print_float (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1324 { 1264 {
1325 char pigbuf[350]; /* see comments in float_to_string */ 1265 char pigbuf[350]; /* see comments in float_to_string */
1326 1266
1327 float_to_string (pigbuf, float_data (XFLOAT (obj))); 1267 float_to_string (pigbuf, XFLOAT_DATA (obj));
1328 write_c_string (pigbuf, printcharfun); 1268 write_c_string (pigbuf, printcharfun);
1329 } 1269 }
1330 #endif /* LISP_FLOAT_TYPE */ 1270 #endif /* LISP_FLOAT_TYPE */
1331 1271
1332 void 1272 void
1429 Bytecount last = 0; 1369 Bytecount last = 0;
1430 1370
1431 XSETSTRING (nameobj, name); 1371 XSETSTRING (nameobj, name);
1432 for (i = 0; i < size; i++) 1372 for (i = 0; i < size; i++)
1433 { 1373 {
1434 Bufbyte c = string_byte (name, i); 1374 switch (string_byte (name, i))
1435
1436 if (c == '\"' || c == '\\' || c == '\'' || c == ';' || c == '#' ||
1437 c == '(' || c == ')' || c == ',' || c =='.' || c == '`' ||
1438 c == '[' || c == ']' || c == '?' || c <= 040)
1439 { 1375 {
1376 case 0: case 1: case 2: case 3:
1377 case 4: case 5: case 6: case 7:
1378 case 8: case 9: case 10: case 11:
1379 case 12: case 13: case 14: case 15:
1380 case 16: case 17: case 18: case 19:
1381 case 20: case 21: case 22: case 23:
1382 case 24: case 25: case 26: case 27:
1383 case 28: case 29: case 30: case 31:
1384 case ' ': case '\"': case '\\': case '\'':
1385 case ';': case '#' : case '(' : case ')':
1386 case ',': case '.' : case '`' :
1387 case '[': case ']' : case '?' :
1440 if (i > last) 1388 if (i > last)
1441 { 1389 output_string (printcharfun, 0, nameobj, last, i - last);
1442 output_string (printcharfun, 0, nameobj, last,
1443 i - last);
1444 }
1445 write_char_internal ("\\", printcharfun); 1390 write_char_internal ("\\", printcharfun);
1446 last = i; 1391 last = i;
1447 } 1392 }
1448 } 1393 }
1449 output_string (printcharfun, 0, nameobj, last, size - last); 1394 output_string (printcharfun, 0, nameobj, last, size - last);
1612 void debug_backtrace (void); 1557 void debug_backtrace (void);
1613 void 1558 void
1614 debug_backtrace (void) 1559 debug_backtrace (void)
1615 { 1560 {
1616 /* This function can GC */ 1561 /* This function can GC */
1617 int old_print_readably = print_readably; 1562 int old_print_readably = print_readably;
1618 int old_print_depth = print_depth; 1563 int old_print_depth = print_depth;
1619 Lisp_Object old_print_length = Vprint_length; 1564 Lisp_Object old_print_length = Vprint_length;
1620 Lisp_Object old_print_level = Vprint_level; 1565 Lisp_Object old_print_level = Vprint_level;
1621 Lisp_Object old_inhibit_quit = Vinhibit_quit; 1566 Lisp_Object old_inhibit_quit = Vinhibit_quit;
1567
1622 struct gcpro gcpro1, gcpro2, gcpro3; 1568 struct gcpro gcpro1, gcpro2, gcpro3;
1623 GCPRO3 (old_print_level, old_print_length, old_inhibit_quit); 1569 GCPRO3 (old_print_level, old_print_length, old_inhibit_quit);
1624 1570
1625 if (gc_in_progress) 1571 if (gc_in_progress)
1626 stderr_out ("** gc-in-progress! Bad idea to print anything! **\n"); 1572 stderr_out ("** gc-in-progress! Bad idea to print anything! **\n");
1631 /* Could use unwind-protect, but why bother? */ 1577 /* Could use unwind-protect, but why bother? */
1632 if (debug_print_length > 0) 1578 if (debug_print_length > 0)
1633 Vprint_length = make_int (debug_print_length); 1579 Vprint_length = make_int (debug_print_length);
1634 if (debug_print_level > 0) 1580 if (debug_print_level > 0)
1635 Vprint_level = make_int (debug_print_level); 1581 Vprint_level = make_int (debug_print_level);
1582
1636 Fbacktrace (Qexternal_debugging_output, Qt); 1583 Fbacktrace (Qexternal_debugging_output, Qt);
1637 stderr_out ("\n"); 1584 stderr_out ("\n");
1638 fflush (stderr); 1585 fflush (stderr);
1639 Vinhibit_quit = old_inhibit_quit; 1586
1640 Vprint_level = old_print_level; 1587 Vinhibit_quit = old_inhibit_quit;
1641 Vprint_length = old_print_length; 1588 Vprint_level = old_print_level;
1642 print_depth = old_print_depth; 1589 Vprint_length = old_print_length;
1590 print_depth = old_print_depth;
1643 print_readably = old_print_readably; 1591 print_readably = old_print_readably;
1644 print_unbuffered--; 1592 print_unbuffered--;
1593
1645 UNGCPRO; 1594 UNGCPRO;
1646 } 1595 }
1647 1596
1648 void 1597 void
1649 debug_short_backtrace (int length) 1598 debug_short_backtrace (int length)
1660 fflush (stderr); 1609 fflush (stderr);
1661 } 1610 }
1662 if (COMPILED_FUNCTIONP (*bt->function)) 1611 if (COMPILED_FUNCTIONP (*bt->function))
1663 { 1612 {
1664 #if defined(COMPILED_FUNCTION_ANNOTATION_HACK) 1613 #if defined(COMPILED_FUNCTION_ANNOTATION_HACK)
1665 Lisp_Object ann = Fcompiled_function_annotation (*bt->function); 1614 Lisp_Object ann =
1615 compiled_function_annotation (XCOMPILED_FUNCTION (*bt->function));
1666 #else 1616 #else
1667 Lisp_Object ann = Qnil; 1617 Lisp_Object ann = Qnil;
1668 #endif 1618 #endif
1669 if (!NILP (ann)) 1619 if (!NILP (ann))
1670 { 1620 {