Mercurial > hg > xemacs-beta

comparison src/print.c @ 5125:b5df3737028a ben-lisp-object

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
merge
author Ben Wing <ben@xemacs.org>
date Wed, 24 Feb 2010 01:58:04 -0600
parents d1247f3cc363 c2e0c3af5fe3
children a9c41067dd88
comparison
equal deleted inserted replaced
5124:623d57b7fbe8 5125:b5df3737028a
1 /* Lisp object printing and output streams. 1 /* Lisp object printing and output streams.
2 Copyright (C) 1985, 1986, 1988, 1992-1995 Free Software Foundation, Inc. 2 Copyright (C) 1985, 1986, 1988, 1992-1995 Free Software Foundation, Inc.
3 Copyright (C) 1995, 1996, 2000, 2001, 2002, 2003, 2005 Ben Wing. 3 Copyright (C) 1995, 1996, 2000, 2001, 2002, 2003, 2005, 2010 Ben Wing.
4 4
5 This file is part of XEmacs. 5 This file is part of XEmacs.
6 6
7 XEmacs is free software; you can redistribute it and/or modify it 7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the 8 under the terms of the GNU General Public License as published by the
112 Lisp_Object Qprint_message_label; 112 Lisp_Object Qprint_message_label;
113 113
114 /* Force immediate output of all printed data. Used for debugging. */ 114 /* Force immediate output of all printed data. Used for debugging. */
115 int print_unbuffered; 115 int print_unbuffered;
116 116
117 /* Non-zero if in debug-printing */
118 int in_debug_print;
119
117 FILE *termscript; /* Stdio stream being used for copy of all output. */ 120 FILE *termscript; /* Stdio stream being used for copy of all output. */
118 121
119 static void write_string_to_alternate_debugging_output (const Ibyte *str, 122 static void write_string_to_alternate_debugging_output (const Ibyte *str,
120 Bytecount len); 123 Bytecount len);
121 124
125 { 128 {
126 int inhibit_non_essential_conversion_operations; 129 int inhibit_non_essential_conversion_operations;
127 int print_depth; 130 int print_depth;
128 int print_readably; 131 int print_readably;
129 int print_unbuffered; 132 int print_unbuffered;
133 int in_debug_print;
130 int gc_currently_forbidden; 134 int gc_currently_forbidden;
131 Lisp_Object Vprint_length; 135 Lisp_Object Vprint_length;
132 Lisp_Object Vprint_level; 136 Lisp_Object Vprint_level;
133 Lisp_Object Vinhibit_quit; 137 Lisp_Object Vinhibit_quit;
134 }; 138 };
135 139
136 static Lisp_Object debug_prin1_bindings; 140 static int begin_inhibit_non_essential_conversion_operations (void);
141
137 142
138 143
139 int stdout_needs_newline; 144 int stdout_needs_newline;
140 int stdout_clear_before_next_output; 145 int stdout_clear_before_next_output;
141 146
356 Works like stderr_out(). */ 361 Works like stderr_out(). */
357 362
358 void 363 void
359 debug_out (const CIbyte *fmt, ...) 364 debug_out (const CIbyte *fmt, ...)
360 { 365 {
366 int depth = begin_inhibit_non_essential_conversion_operations ();
361 va_list args; 367 va_list args;
362 va_start (args, fmt); 368 va_start (args, fmt);
363 write_string_to_external_output_va (fmt, args, EXT_PRINT_ALL); 369 write_string_to_external_output_va (fmt, args, EXT_PRINT_ALL);
364 va_end (args); 370 va_end (args);
371 unbind_to (depth);
365 } 372 }
366 373
367 DOESNT_RETURN 374 DOESNT_RETURN
368 fatal (const CIbyte *fmt, ...) 375 fatal (const CIbyte *fmt, ...)
369 { 376 {
649 #endif 656 #endif
650 output_string (stream, str, Qnil, 0, size); 657 output_string (stream, str, Qnil, 0, size);
651 } 658 }
652 659
653 void 660 void
654 write_string (Lisp_Object stream, const Ibyte *str) 661 write_istring (Lisp_Object stream, const Ibyte *str)
655 { 662 {
656 /* This function can GC */ 663 /* This function can GC */
657 write_string_1 (stream, str, qxestrlen (str)); 664 write_string_1 (stream, str, qxestrlen (str));
658 } 665 }
659 666
660 void 667 void
661 write_c_string (Lisp_Object stream, const CIbyte *str) 668 write_cistring (Lisp_Object stream, const CIbyte *str)
662 { 669 {
663 /* This function can GC */ 670 /* This function can GC */
664 write_string_1 (stream, (const Ibyte *) str, strlen (str)); 671 write_istring (stream, (const Ibyte *) str);
672 }
673
674 void
675 write_ascstring (Lisp_Object stream, const Ascbyte *str)
676 {
677 /* This function can GC */
678 ASSERT_ASCTEXT_ASCII (str);
679 write_istring (stream, (const Ibyte *) str);
680 }
681
682 void
683 write_msg_istring (Lisp_Object stream, const Ibyte *str)
684 {
685 /* This function can GC */
686 write_istring (stream, IGETTEXT (str));
687 }
688
689 void
690 write_msg_cistring (Lisp_Object stream, const CIbyte *str)
691 {
692 /* This function can GC */
693 write_msg_istring (stream, (const Ibyte *) str);
694 }
695
696 void
697 write_msg_ascstring (Lisp_Object stream, const Ascbyte *str)
698 {
699 /* This function can GC */
700 ASSERT_ASCTEXT_ASCII (str);
701 write_msg_istring (stream, (const Ibyte *) str);
665 } 702 }
666 703
667 void 704 void
668 write_eistring (Lisp_Object stream, const Eistring *ei) 705 write_eistring (Lisp_Object stream, const Eistring *ei)
669 { 706 {
842 If STREAM is omitted or nil, the value of `standard-output' is used. 879 If STREAM is omitted or nil, the value of `standard-output' is used.
843 */ 880 */
844 (stream)) 881 (stream))
845 { 882 {
846 /* This function can GC */ 883 /* This function can GC */
847 write_c_string (canonicalize_printcharfun (stream), "\n"); 884 write_ascstring (canonicalize_printcharfun (stream), "\n");
848 return Qt; 885 return Qt;
849 } 886 }
850 887
851 DEFUN ("prin1", Fprin1, 1, 2, 0, /* 888 DEFUN ("prin1", Fprin1, 1, 2, 0, /*
852 Output the printed representation of OBJECT, any Lisp object. 889 Output the printed representation of OBJECT, any Lisp object.
939 Lisp_Object frame = Qnil; 976 Lisp_Object frame = Qnil;
940 struct gcpro gcpro1, gcpro2; 977 struct gcpro gcpro1, gcpro2;
941 978
942 GCPRO2 (object, stream); 979 GCPRO2 (object, stream);
943 stream = print_prepare (stream, &frame); 980 stream = print_prepare (stream, &frame);
944 write_c_string (stream, "\n"); 981 write_ascstring (stream, "\n");
945 print_internal (object, stream, 1); 982 print_internal (object, stream, 1);
946 write_c_string (stream, "\n"); 983 write_ascstring (stream, "\n");
947 print_finish (stream, frame); 984 print_finish (stream, frame);
948 UNGCPRO; 985 UNGCPRO;
949 return object; 986 return object;
950 } 987 }
951 988
1017 else 1054 else
1018 print_internal (LISP_GETTEXT (errmsg), stream, 0); 1055 print_internal (LISP_GETTEXT (errmsg), stream, 0);
1019 } 1056 }
1020 while (!NILP (tail)) 1057 while (!NILP (tail))
1021 { 1058 {
1022 write_c_string (stream, first ? ": " : ", "); 1059 write_ascstring (stream, first ? ": " : ", ");
1023 /* Most errors have an explanatory string as their first argument, 1060 /* Most errors have an explanatory string as their first argument,
1024 and it looks better not to put the quotes around it. */ 1061 and it looks better not to put the quotes around it. */
1025 print_internal (Fcar (tail), stream, 1062 print_internal (Fcar (tail), stream,
1026 !(first && STRINGP (Fcar (tail))) || 1063 !(first && STRINGP (Fcar (tail))) ||
1027 !NILP (Fget (type, Qerror_lacks_explanatory_string, 1064 !NILP (Fget (type, Qerror_lacks_explanatory_string,
1037 } 1074 }
1038 1075
1039 error_throw: 1076 error_throw:
1040 if (NILP (method)) 1077 if (NILP (method))
1041 { 1078 {
1042 write_c_string (stream, GETTEXT ("Peculiar error ")); 1079 write_ascstring (stream, GETTEXT ("Peculiar error "));
1043 print_internal (error_object, stream, 1); 1080 print_internal (error_object, stream, 1);
1044 return; 1081 return;
1045 } 1082 }
1046 else 1083 else
1047 { 1084 {
1321 { 1358 {
1322 int max = XINT (Vprint_length); 1359 int max = XINT (Vprint_length);
1323 if (max < len) last = max; 1360 if (max < len) last = max;
1324 } 1361 }
1325 1362
1326 write_c_string (printcharfun, start); 1363 write_cistring (printcharfun, start);
1327 for (i = 0; i < last; i++) 1364 for (i = 0; i < last; i++)
1328 { 1365 {
1329 Lisp_Object elt = XVECTOR_DATA (obj)[i]; 1366 Lisp_Object elt = XVECTOR_DATA (obj)[i];
1330 if (i != 0) write_c_string (printcharfun, " "); 1367 if (i != 0) write_ascstring (printcharfun, " ");
1331 print_internal (elt, printcharfun, escapeflag); 1368 print_internal (elt, printcharfun, escapeflag);
1332 } 1369 }
1333 UNGCPRO; 1370 UNGCPRO;
1334 if (last != len) 1371 if (last != len)
1335 write_c_string (printcharfun, " ..."); 1372 write_ascstring (printcharfun, " ...");
1336 write_c_string (printcharfun, end); 1373 write_cistring (printcharfun, end);
1337 } 1374 }
1338 1375
1339 void 1376 void
1340 print_cons (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 1377 print_cons (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1341 { 1378 {
1352 CONSP (XCDR (obj)) && 1389 CONSP (XCDR (obj)) &&
1353 NILP (XCDR (XCDR (obj)))) 1390 NILP (XCDR (XCDR (obj))))
1354 { 1391 {
1355 obj = XCAR (XCDR (obj)); 1392 obj = XCAR (XCDR (obj));
1356 GCPRO2 (obj, printcharfun); 1393 GCPRO2 (obj, printcharfun);
1357 write_c_string (printcharfun, "\'"); 1394 write_ascstring (printcharfun, "\'");
1358 UNGCPRO; 1395 UNGCPRO;
1359 print_internal (obj, printcharfun, escapeflag); 1396 print_internal (obj, printcharfun, escapeflag);
1360 return; 1397 return;
1361 } 1398 }
1362 1399
1363 GCPRO2 (obj, printcharfun); 1400 GCPRO2 (obj, printcharfun);
1364 write_c_string (printcharfun, "("); 1401 write_ascstring (printcharfun, "(");
1365 1402
1366 { 1403 {
1367 int len; 1404 int len;
1368 int max = INTP (Vprint_length) ? XINT (Vprint_length) : INT_MAX; 1405 int max = INTP (Vprint_length) ? XINT (Vprint_length) : INT_MAX;
1369 Lisp_Object tortoise; 1406 Lisp_Object tortoise;
1372 for (tortoise = obj, len = 0; 1409 for (tortoise = obj, len = 0;
1373 CONSP (obj); 1410 CONSP (obj);
1374 obj = XCDR (obj), len++) 1411 obj = XCDR (obj), len++)
1375 { 1412 {
1376 if (len > 0) 1413 if (len > 0)
1377 write_c_string (printcharfun, " "); 1414 write_ascstring (printcharfun, " ");
1378 if (EQ (obj, tortoise) && len > 0) 1415 if (EQ (obj, tortoise) && len > 0)
1379 { 1416 {
1380 if (print_readably) 1417 if (print_readably)
1381 printing_unreadable_object ("circular list"); 1418 printing_unreadable_object ("circular list");
1382 else 1419 else
1383 write_c_string (printcharfun, "... <circular list>"); 1420 write_ascstring (printcharfun, "... <circular list>");
1384 break; 1421 break;
1385 } 1422 }
1386 if (len & 1) 1423 if (len & 1)
1387 tortoise = XCDR (tortoise); 1424 tortoise = XCDR (tortoise);
1388 if (len > max) 1425 if (len > max)
1389 { 1426 {
1390 write_c_string (printcharfun, "..."); 1427 write_ascstring (printcharfun, "...");
1391 break; 1428 break;
1392 } 1429 }
1393 print_internal (XCAR (obj), printcharfun, escapeflag); 1430 print_internal (XCAR (obj), printcharfun, escapeflag);
1394 } 1431 }
1395 } 1432 }
1396 if (!LISTP (obj)) 1433 if (!LISTP (obj))
1397 { 1434 {
1398 write_c_string (printcharfun, " . "); 1435 write_ascstring (printcharfun, " . ");
1399 print_internal (obj, printcharfun, escapeflag); 1436 print_internal (obj, printcharfun, escapeflag);
1400 } 1437 }
1401 UNGCPRO; 1438 UNGCPRO;
1402 1439
1403 write_c_string (printcharfun, ")"); 1440 write_ascstring (printcharfun, ")");
1404 return; 1441 return;
1405 } 1442 }
1406 1443
1407 void 1444 void
1408 print_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 1445 print_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1436 if (!escapeflag) 1473 if (!escapeflag)
1437 { 1474 {
1438 /* This deals with GC-relocation and Mule. */ 1475 /* This deals with GC-relocation and Mule. */
1439 output_string (printcharfun, 0, obj, 0, bcmax); 1476 output_string (printcharfun, 0, obj, 0, bcmax);
1440 if (max < size) 1477 if (max < size)
1441 write_c_string (printcharfun, " ..."); 1478 write_ascstring (printcharfun, " ...");
1442 } 1479 }
1443 else 1480 else
1444 { 1481 {
1445 Bytecount i, last = 0; 1482 Bytecount i, last = 0;
1446 1483
1447 write_c_string (printcharfun, "\""); 1484 write_ascstring (printcharfun, "\"");
1448 for (i = 0; i < bcmax; i++) 1485 for (i = 0; i < bcmax; i++)
1449 { 1486 {
1450 Ibyte ch = string_byte (obj, i); 1487 Ibyte ch = string_byte (obj, i);
1451 if (ch == '\"' || ch == '\\' 1488 if (ch == '\"' || ch == '\\'
1452 || (ch == '\n' && print_escape_newlines)) 1489 || (ch == '\n' && print_escape_newlines))
1456 output_string (printcharfun, 0, obj, last, 1493 output_string (printcharfun, 0, obj, last,
1457 i - last); 1494 i - last);
1458 } 1495 }
1459 if (ch == '\n') 1496 if (ch == '\n')
1460 { 1497 {
1461 write_c_string (printcharfun, "\\n"); 1498 write_ascstring (printcharfun, "\\n");
1462 } 1499 }
1463 else 1500 else
1464 { 1501 {
1465 Ibyte temp[2]; 1502 Ibyte temp[2];
1466 write_c_string (printcharfun, "\\"); 1503 write_ascstring (printcharfun, "\\");
1467 /* This is correct for Mule because the 1504 /* This is correct for Mule because the
1468 character is either \ or " */ 1505 character is either \ or " */
1469 temp[0] = string_byte (obj, i); 1506 temp[0] = string_byte (obj, i);
1470 temp[1] = '\0'; 1507 temp[1] = '\0';
1471 write_string (printcharfun, temp); 1508 write_istring (printcharfun, temp);
1472 } 1509 }
1473 last = i + 1; 1510 last = i + 1;
1474 } 1511 }
1475 } 1512 }
1476 if (bcmax > last) 1513 if (bcmax > last)
1477 { 1514 {
1478 output_string (printcharfun, 0, obj, last, 1515 output_string (printcharfun, 0, obj, last,
1479 bcmax - last); 1516 bcmax - last);
1480 } 1517 }
1481 if (max < size) 1518 if (max < size)
1482 write_c_string (printcharfun, " ..."); 1519 write_ascstring (printcharfun, " ...");
1483 write_c_string (printcharfun, "\""); 1520 write_ascstring (printcharfun, "\"");
1484 } 1521 }
1485 UNGCPRO; 1522 UNGCPRO;
1486 } 1523 }
1487 1524
1488 void 1525 DOESNT_RETURN
1489 external_object_printer (Lisp_Object obj, Lisp_Object printcharfun, 1526 printing_unreadable_object (const Ascbyte *fmt, ...)
1490 int UNUSED (escapeflag)) 1527 {
1528 Lisp_Object obj;
1529 va_list args;
1530
1531 va_start (args, fmt);
1532 obj = emacs_vsprintf_string (GETTEXT (fmt), args);
1533 va_end (args);
1534
1535 /* Fsignal GC-protects its args */
1536 signal_error (Qprinting_unreadable_object, 0, obj);
1537 }
1538
1539 DOESNT_RETURN
1540 printing_unreadable_lcrecord (Lisp_Object obj, const Ibyte *name)
1491 { 1541 {
1492 LISP_OBJECT_HEADER *header = (LISP_OBJECT_HEADER *) XPNTR (obj); 1542 LISP_OBJECT_HEADER *header = (LISP_OBJECT_HEADER *) XPNTR (obj);
1493 1543
1494 if (print_readably) 1544 #ifndef NEW_GC
1545 /* This must be a real lcrecord */
1546 assert (!LHEADER_IMPLEMENTATION (&header->lheader)->basic_p);
1547 #endif
1548
1549 if (name)
1550 printing_unreadable_object
1551 ("#<%s %s 0x%x>",
1552 #ifdef NEW_GC
1553 LHEADER_IMPLEMENTATION (header)->name,
1554 #else /* not NEW_GC */
1555 LHEADER_IMPLEMENTATION (&header->lheader)->name,
1556 #endif /* not NEW_GC */
1557 name,
1558 header->uid);
1559 else
1495 printing_unreadable_object 1560 printing_unreadable_object
1496 ("#<%s 0x%x>", 1561 ("#<%s 0x%x>",
1497 #ifdef NEW_GC 1562 #ifdef NEW_GC
1498 LHEADER_IMPLEMENTATION (header)->name, 1563 LHEADER_IMPLEMENTATION (header)->name,
1499 #else /* not NEW_GC */ 1564 #else /* not NEW_GC */
1500 LHEADER_IMPLEMENTATION (&header->lheader)->name, 1565 LHEADER_IMPLEMENTATION (&header->lheader)->name,
1501 #endif /* not NEW_GC */ 1566 #endif /* not NEW_GC */
1502 header->uid); 1567 header->uid);
1568 }
1569
1570 void
1571 external_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
1572 int UNUSED (escapeflag))
1573 {
1574 LISP_OBJECT_HEADER *header = (LISP_OBJECT_HEADER *) XPNTR (obj);
1575
1576 #ifndef NEW_GC
1577 /* This must be a real lcrecord */
1578 assert (!LHEADER_IMPLEMENTATION (&header->lheader)->basic_p);
1579 #endif
1580
1581 if (print_readably)
1582 printing_unreadable_lcrecord (obj, 0);
1503 1583
1504 write_fmt_string (printcharfun, "#<%s 0x%x>", 1584 write_fmt_string (printcharfun, "#<%s 0x%x>",
1505 #ifdef NEW_GC 1585 #ifdef NEW_GC
1506 LHEADER_IMPLEMENTATION (header)->name, 1586 LHEADER_IMPLEMENTATION (header)->name,
1507 #else /* not NEW_GC */ 1587 #else /* not NEW_GC */
1518 printing_unreadable_object 1598 printing_unreadable_object
1519 ("#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%lx>", 1599 ("#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%lx>",
1520 XRECORD_LHEADER_IMPLEMENTATION (obj)->name, 1600 XRECORD_LHEADER_IMPLEMENTATION (obj)->name,
1521 (unsigned long) XPNTR (obj)); 1601 (unsigned long) XPNTR (obj));
1522 1602
1603 /* Internal objects shouldn't normally escape to the Lisp level;
1604 that's why we say "XEmacs bug?". This can happen, however, when
1605 printing backtraces. */
1523 write_fmt_string (printcharfun, 1606 write_fmt_string (printcharfun,
1524 "#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%lx>", 1607 "#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%lx>",
1525 XRECORD_LHEADER_IMPLEMENTATION (obj)->name, 1608 XRECORD_LHEADER_IMPLEMENTATION (obj)->name,
1526 (unsigned long) XPNTR (obj)); 1609 (unsigned long) XPNTR (obj));
1527 } 1610 }
1528 1611
1529 enum printing_badness 1612 enum printing_badness
1530 { 1613 {
1531 BADNESS_INTEGER_OBJECT, 1614 BADNESS_INTEGER_OBJECT,
1532 BADNESS_POINTER_OBJECT, 1615 BADNESS_POINTER_OBJECT,
1616 BADNESS_POINTER_OBJECT_WITH_DATA,
1533 BADNESS_NO_TYPE 1617 BADNESS_NO_TYPE
1534 }; 1618 };
1535 1619
1536 static void 1620 static void
1537 printing_major_badness (Lisp_Object printcharfun, 1621 printing_major_badness (Lisp_Object printcharfun,
1538 const Ascbyte *badness_string, int type, void *val, 1622 const Ascbyte *badness_string, int type, void *val,
1539 enum printing_badness badness) 1623 void *val2, enum printing_badness badness)
1540 { 1624 {
1541 Ibyte buf[666]; 1625 Ibyte buf[666];
1542 1626
1543 switch (badness) 1627 switch (badness)
1544 { 1628 {
1545 case BADNESS_INTEGER_OBJECT: 1629 case BADNESS_INTEGER_OBJECT:
1546 qxesprintf (buf, "%s %d object %ld", badness_string, type, 1630 qxesprintf (buf, "%s type %d object %ld", badness_string, type,
1547 (EMACS_INT) val); 1631 (EMACS_INT) val);
1548 break; 1632 break;
1549 1633
1550 case BADNESS_POINTER_OBJECT: 1634 case BADNESS_POINTER_OBJECT:
1551 qxesprintf (buf, "%s %d object %p", badness_string, type, val); 1635 qxesprintf (buf, "%s type %d object %p", badness_string, type, val);
1636 break;
1637
1638 case BADNESS_POINTER_OBJECT_WITH_DATA:
1639 qxesprintf (buf, "%s type %d object %p data %p", badness_string, type,
1640 val, val2);
1552 break; 1641 break;
1553 1642
1554 case BADNESS_NO_TYPE: 1643 case BADNESS_NO_TYPE:
1555 qxesprintf (buf, "%s object %p", badness_string, val); 1644 qxesprintf (buf, "%s object %p", badness_string, val);
1556 break; 1645 break;
1562 { 1651 {
1563 #ifdef ERROR_CHECK_TYPES 1652 #ifdef ERROR_CHECK_TYPES
1564 ABORT (); 1653 ABORT ();
1565 #else /* not ERROR_CHECK_TYPES */ 1654 #else /* not ERROR_CHECK_TYPES */
1566 if (print_readably) 1655 if (print_readably)
1567 signal_ferror (Qinternal_error, "printing %s", buf); 1656 signal_ferror (Qinternal_error, "SERIOUS XEMACS BUG: printing %s; "
1657 "save your buffers immediately and please report "
1658 "this bug", buf);
1568 #endif /* not ERROR_CHECK_TYPES */ 1659 #endif /* not ERROR_CHECK_TYPES */
1569 } 1660 }
1570 write_fmt_string (printcharfun, 1661 write_fmt_string (printcharfun,
1571 "#<EMACS BUG: %s Save your buffers immediately and " 1662 "#<SERIOUS XEMACS BUG: %s Save your buffers immediately "
1572 "please report this bug>", buf); 1663 "and please report this bug>", buf);
1573 } 1664 }
1574 1665
1575 void 1666 void
1576 print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 1667 print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1577 { 1668 {
1586 if (gc_in_progress) return; 1677 if (gc_in_progress) return;
1587 #endif 1678 #endif
1588 1679
1589 /* Just to be safe ... */ 1680 /* Just to be safe ... */
1590 GCPRO2 (obj, printcharfun); 1681 GCPRO2 (obj, printcharfun);
1682
1683 /* WARNING WARNING WARNING!!! Don't put anything here that might
1684 dereference memory. Instead, put it down inside of
1685 the case Lisp_Type_Record, after the appropriate checks to make sure
1686 we're not dereferencing bad memory. The idea is that, ideally,
1687 calling debug_print() should *NEVER* make the program crash, even when
1688 something very bad has happened. --ben */
1591 1689
1592 #ifdef I18N3 1690 #ifdef I18N3
1593 /* #### Both input and output streams should have a flag associated 1691 /* #### Both input and output streams should have a flag associated
1594 with them indicating whether output to that stream, or strings 1692 with them indicating whether output to that stream, or strings
1595 read from the stream, get translated using Fgettext(). Such a 1693 read from the stream, get translated using Fgettext(). Such a
1599 it creates. This flag should also be user-settable. Perhaps it 1697 it creates. This flag should also be user-settable. Perhaps it
1600 should be split up into two flags, one for input and one for 1698 should be split up into two flags, one for input and one for
1601 output. */ 1699 output. */
1602 #endif 1700 #endif
1603 1701
1604 /* Detect circularities and truncate them.
1605 No need to offer any alternative--this is better than an error. */
1606 if (CONSP (obj) || VECTORP (obj) || COMPILED_FUNCTIONP (obj))
1607 {
1608 int i;
1609 for (i = 0; i < print_depth; i++)
1610 if (EQ (obj, being_printed[i]))
1611 {
1612 char buf[DECIMAL_PRINT_SIZE (long) + 1];
1613 *buf = '#';
1614 long_to_string (buf + 1, i);
1615 write_c_string (printcharfun, buf);
1616 UNGCPRO;
1617 return;
1618 }
1619 }
1620
1621 being_printed[print_depth] = obj; 1702 being_printed[print_depth] = obj;
1622 1703
1623 /* Avoid calling internal_bind_int, which conses, when called from 1704 /* Avoid calling internal_bind_int, which conses, when called from
1624 debug_prin1. In that case, we have bound print_depth to 0 anyway. */ 1705 debug_prin1. In that case, we have bound print_depth to 0 anyway. */
1625 if (!inhibit_non_essential_conversion_operations) 1706 if (!inhibit_non_essential_conversion_operations)
1626 { 1707 {
1627 specdepth = internal_bind_int (&print_depth, print_depth + 1); 1708 specdepth = internal_bind_int (&print_depth, print_depth + 1);
1628 1709
1629 if (print_depth > PRINT_CIRCLE) 1710 if (print_depth > PRINT_CIRCLE)
1630 signal_error (Qstack_overflow, "Apparently circular structure being printed", Qunbound); 1711 signal_error (Qstack_overflow,
1712 "Apparently circular structure being printed", Qunbound);
1631 } 1713 }
1632 1714
1633 switch (XTYPE (obj)) 1715 switch (XTYPE (obj))
1634 { 1716 {
1635 case Lisp_Type_Int_Even: 1717 case Lisp_Type_Int_Even:
1636 case Lisp_Type_Int_Odd: 1718 case Lisp_Type_Int_Odd:
1637 { 1719 {
1638 char buf[DECIMAL_PRINT_SIZE (EMACS_INT)]; 1720 Ascbyte buf[DECIMAL_PRINT_SIZE (EMACS_INT)];
1639 long_to_string (buf, XINT (obj)); 1721 long_to_string (buf, XINT (obj));
1640 write_c_string (printcharfun, buf); 1722 write_ascstring (printcharfun, buf);
1641 break; 1723 break;
1642 } 1724 }
1643 1725
1644 case Lisp_Type_Char: 1726 case Lisp_Type_Char:
1645 { 1727 {
1708 1790
1709 case Lisp_Type_Record: 1791 case Lisp_Type_Record:
1710 { 1792 {
1711 struct lrecord_header *lheader = XRECORD_LHEADER (obj); 1793 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
1712 1794
1713 /* Try to check for various sorts of bogus pointers if we're in a 1795 /* Try to check for various sorts of bogus pointers or bad memory
1714 situation where it may be likely -- i.e. called from 1796 if we're in a situation where it may be likely -- i.e. called
1715 debug_print() or we're already crashing. In such cases, 1797 from debug_print() or we're already crashing. In such cases,
1716 (further) crashing is counterproductive. */ 1798 (further) crashing is counterproductive.
1717 1799
1800 We don't normally do these because they may be expensive or
1801 weird (e.g. under Unix we typically have to set a SIGSEGV
1802 handler and try to trigger a seg fault). */
1803
1804 if (!lheader)
1805 {
1806 /* i.e. EQ Qnull_pointer */
1807 printing_major_badness (printcharfun, "NULL POINTER LRECORD", 0,
1808 0, 0, BADNESS_NO_TYPE);
1809 break;
1810 }
1811
1812 /* First check to see if the lrecord header itself is garbage. */
1718 if (inhibit_non_essential_conversion_operations && 1813 if (inhibit_non_essential_conversion_operations &&
1719 !debug_can_access_memory (lheader, sizeof (*lheader))) 1814 !debug_can_access_memory (lheader, sizeof (*lheader)))
1720 { 1815 {
1721 write_fmt_string (printcharfun, "#<EMACS BUG: BAD MEMORY %p>", 1816 printing_major_badness (printcharfun,
1722 lheader); 1817 "BAD MEMORY in LRECORD HEADER", 0,
1818 lheader, 0, BADNESS_NO_TYPE);
1723 break; 1819 break;
1724 }
1725
1726 if (CONSP (obj) || VECTORP (obj))
1727 {
1728 /* If deeper than spec'd depth, print placeholder. */
1729 if (INTP (Vprint_level)
1730 && print_depth > XINT (Vprint_level))
1731 {
1732 write_c_string (printcharfun, "...");
1733 break;
1734 }
1735 } 1820 }
1736 1821
1822 /* Check to see if the lrecord type is garbage. */
1737 #ifndef NEW_GC 1823 #ifndef NEW_GC
1738 if (lheader->type == lrecord_type_free) 1824 if (lheader->type == lrecord_type_free)
1739 { 1825 {
1740 printing_major_badness (printcharfun, "freed lrecord", 0, 1826 printing_major_badness (printcharfun, "FREED LRECORD", 0,
1741 lheader, BADNESS_NO_TYPE); 1827 lheader, 0, BADNESS_NO_TYPE);
1742 break; 1828 break;
1743 } 1829 }
1744 else if (lheader->type == lrecord_type_undefined) 1830 if (lheader->type == lrecord_type_undefined)
1745 { 1831 {
1746 printing_major_badness (printcharfun, "lrecord_type_undefined", 0, 1832 printing_major_badness (printcharfun, "LRECORD_TYPE_UNDEFINED", 0,
1747 lheader, BADNESS_NO_TYPE); 1833 lheader, 0, BADNESS_NO_TYPE);
1748 break; 1834 break;
1749 } 1835 }
1750 #endif /* not NEW_GC */ 1836 #endif /* not NEW_GC */
1751 else if ((int) (lheader->type) >= lrecord_type_count) 1837 if ((int) (lheader->type) >= lrecord_type_count)
1752 { 1838 {
1753 printing_major_badness (printcharfun, "illegal lrecord type", 1839 printing_major_badness (printcharfun, "ILLEGAL LRECORD TYPE",
1754 (int) (lheader->type), 1840 (int) (lheader->type),
1755 lheader, BADNESS_POINTER_OBJECT); 1841 lheader, 0, BADNESS_POINTER_OBJECT);
1756 break; 1842 break;
1757 } 1843 }
1758 1844
1759 /* Further checks for bad memory in critical situations. We don't 1845 /* Check to see if the lrecord implementation is missing or garbage. */
1760 normally do these because they may be expensive or weird 1846 {
1761 (e.g. under Unix we typically have to set a SIGSEGV handler and 1847 const struct lrecord_implementation *imp =
1762 try to trigger a seg fault). */ 1848 LHEADER_IMPLEMENTATION (lheader);
1849
1850 if (!imp)
1851 {
1852 printing_major_badness
1853 (printcharfun, "NO IMPLEMENTATION FOR LRECORD TYPE",
1854 (int) (lheader->type),
1855 lheader, 0, BADNESS_POINTER_OBJECT);
1856 break;
1857 }
1858
1859 if (inhibit_non_essential_conversion_operations)
1860 {
1861 if (!debug_can_access_memory (imp, sizeof (*imp)))
1862 {
1863 printing_major_badness
1864 (printcharfun, "BAD MEMORY IN LRECORD IMPLEMENTATION",
1865 (int) (lheader->type),
1866 lheader, 0, BADNESS_POINTER_OBJECT);
1867 }
1868 }
1869 }
1870
1871 /* Check to see if any of the memory of the lrecord is inaccessible.
1872 Note that we already checked above to see if the first part of
1873 the lrecord (the header) is inaccessible, which will catch most
1874 cases of a totally bad pointer. */
1763 1875
1764 if (inhibit_non_essential_conversion_operations) 1876 if (inhibit_non_essential_conversion_operations)
1765 { 1877 {
1766 if (!debug_can_access_memory 1878 if (!debug_can_access_memory
1767 (lheader, detagged_lisp_object_size (lheader))) 1879 (lheader, detagged_lisp_object_size (lheader)))
1768 { 1880 {
1769 write_fmt_string (printcharfun, 1881 printing_major_badness (printcharfun,
1770 "#<EMACS BUG: type %s BAD MEMORY %p>", 1882 "BAD MEMORY IN LRECORD",
1771 LHEADER_IMPLEMENTATION (lheader)->name, 1883 (int) (lheader->type),
1772 lheader); 1884 lheader, 0, BADNESS_POINTER_OBJECT);
1773 break; 1885 break;
1774 } 1886 }
1775 1887
1888 /* For strings, also check the data of the string itself. */
1776 if (STRINGP (obj)) 1889 if (STRINGP (obj))
1777 { 1890 {
1778 #ifdef NEW_GC 1891 #ifdef NEW_GC
1779 if (!debug_can_access_memory (XSTRING_DATA (obj), 1892 if (!debug_can_access_memory (XSTRING_DATA (obj),
1780 XSTRING_LENGTH (obj))) 1893 XSTRING_LENGTH (obj)))
1787 } 1900 }
1788 #else /* not NEW_GC */ 1901 #else /* not NEW_GC */
1789 Lisp_String *l = (Lisp_String *) lheader; 1902 Lisp_String *l = (Lisp_String *) lheader;
1790 if (!debug_can_access_memory (l->data_, l->size_)) 1903 if (!debug_can_access_memory (l->data_, l->size_))
1791 { 1904 {
1792 write_fmt_string 1905 printing_major_badness (printcharfun,
1793 (printcharfun, 1906 "BAD STRING DATA", (int) (lheader->type),
1794 "#<EMACS BUG: %p (BAD STRING DATA %p)>", 1907 lheader, l->data_,
1795 lheader, l->data_); 1908 BADNESS_POINTER_OBJECT_WITH_DATA);
1796 break; 1909 break;
1797 } 1910 }
1798 #endif /* not NEW_GC */ 1911 #endif /* not NEW_GC */
1912 }
1913 }
1914
1915 /* Detect circularities and truncate them.
1916 No need to offer any alternative--this is better than an error. */
1917 if (CONSP (obj) || VECTORP (obj) || COMPILED_FUNCTIONP (obj))
1918 {
1919 int i;
1920 for (i = 0; i < print_depth - 1; i++)
1921 if (EQ (obj, being_printed[i]))
1922 {
1923 Ascbyte buf[DECIMAL_PRINT_SIZE (long) + 1];
1924 *buf = '#';
1925 long_to_string (buf + 1, i);
1926 write_ascstring (printcharfun, buf);
1927 break;
1928 }
1929 if (i < print_depth - 1) /* Did we print something? */
1930 break;
1931 }
1932
1933 if (CONSP (obj) || VECTORP (obj))
1934 {
1935 /* If deeper than spec'd depth, print placeholder. */
1936 if (INTP (Vprint_level)
1937 && print_depth > XINT (Vprint_level))
1938 {
1939 write_ascstring (printcharfun, "...");
1940 break;
1799 } 1941 }
1800 } 1942 }
1801 1943
1802 /* Either use a custom-written printer, or use 1944 /* Either use a custom-written printer, or use
1803 internal_object_printer or external_object_printer, depending on 1945 internal_object_printer or external_object_printer, depending on
1810 } 1952 }
1811 1953
1812 default: 1954 default:
1813 { 1955 {
1814 /* We're in trouble if this happens! */ 1956 /* We're in trouble if this happens! */
1815 printing_major_badness (printcharfun, "illegal data type", XTYPE (obj), 1957 printing_major_badness (printcharfun, "ILLEGAL LISP OBJECT TAG TYPE",
1816 LISP_TO_VOID (obj), BADNESS_INTEGER_OBJECT); 1958 XTYPE (obj), STORE_LISP_IN_VOID (obj), 0,
1959 BADNESS_INTEGER_OBJECT);
1817 break; 1960 break;
1818 } 1961 }
1819 } 1962 }
1820 1963
1821 if (!inhibit_non_essential_conversion_operations) 1964 if (!inhibit_non_essential_conversion_operations)
1825 1968
1826 void 1969 void
1827 print_float (Lisp_Object obj, Lisp_Object printcharfun, 1970 print_float (Lisp_Object obj, Lisp_Object printcharfun,
1828 int UNUSED (escapeflag)) 1971 int UNUSED (escapeflag))
1829 { 1972 {
1830 char pigbuf[350]; /* see comments in float_to_string */ 1973 Ascbyte pigbuf[350]; /* see comments in float_to_string */
1831 1974
1832 float_to_string (pigbuf, XFLOAT_DATA (obj)); 1975 float_to_string (pigbuf, XFLOAT_DATA (obj));
1833 write_c_string (printcharfun, pigbuf); 1976 write_ascstring (printcharfun, pigbuf);
1834 } 1977 }
1835 1978
1836 void 1979 void
1837 print_symbol (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 1980 print_symbol (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1838 { 1981 {
1864 if (print_depth > 1) 2007 if (print_depth > 1)
1865 { 2008 {
1866 Lisp_Object tem = Fassq (obj, Vprint_gensym_alist); 2009 Lisp_Object tem = Fassq (obj, Vprint_gensym_alist);
1867 if (CONSP (tem)) 2010 if (CONSP (tem))
1868 { 2011 {
1869 write_c_string (printcharfun, "#"); 2012 write_ascstring (printcharfun, "#");
1870 print_internal (XCDR (tem), printcharfun, escapeflag); 2013 print_internal (XCDR (tem), printcharfun, escapeflag);
1871 write_c_string (printcharfun, "#"); 2014 write_ascstring (printcharfun, "#");
1872 UNGCPRO; 2015 UNGCPRO;
1873 return; 2016 return;
1874 } 2017 }
1875 else 2018 else
1876 { 2019 {
1884 } 2027 }
1885 else 2028 else
1886 tem = make_int (1); 2029 tem = make_int (1);
1887 Vprint_gensym_alist = Fcons (Fcons (obj, tem), Vprint_gensym_alist); 2030 Vprint_gensym_alist = Fcons (Fcons (obj, tem), Vprint_gensym_alist);
1888 2031
1889 write_c_string (printcharfun, "#"); 2032 write_ascstring (printcharfun, "#");
1890 print_internal (tem, printcharfun, escapeflag); 2033 print_internal (tem, printcharfun, escapeflag);
1891 write_c_string (printcharfun, "="); 2034 write_ascstring (printcharfun, "=");
1892 } 2035 }
1893 } 2036 }
1894 write_c_string (printcharfun, "#:"); 2037 write_ascstring (printcharfun, "#:");
1895 } 2038 }
1896 2039
1897 /* Does it look like an integer or a float? */ 2040 /* Does it look like an integer or a float? */
1898 { 2041 {
1899 Ibyte *data = XSTRING_DATA (name); 2042 Ibyte *data = XSTRING_DATA (name);
1924 /* #### Ugh, this is needlessly complex and slow for what we 2067 /* #### Ugh, this is needlessly complex and slow for what we
1925 need here. It might be a good idea to copy equivalent code 2068 need here. It might be a good idea to copy equivalent code
1926 from FSF. --hniksic */ 2069 from FSF. --hniksic */
1927 confusing = isfloat_string ((char *) data); 2070 confusing = isfloat_string ((char *) data);
1928 if (confusing) 2071 if (confusing)
1929 write_c_string (printcharfun, "\\"); 2072 write_ascstring (printcharfun, "\\");
1930 } 2073 }
1931 2074
1932 { 2075 {
1933 Bytecount i; 2076 Bytecount i;
1934 Bytecount last = 0; 2077 Bytecount last = 0;
1949 case ';': case '#' : case '(' : case ')': 2092 case ';': case '#' : case '(' : case ')':
1950 case ',': case '.' : case '`' : 2093 case ',': case '.' : case '`' :
1951 case '[': case ']' : case '?' : 2094 case '[': case ']' : case '?' :
1952 if (i > last) 2095 if (i > last)
1953 output_string (printcharfun, 0, name, last, i - last); 2096 output_string (printcharfun, 0, name, last, i - last);
1954 write_c_string (printcharfun, "\\"); 2097 write_ascstring (printcharfun, "\\");
1955 last = i; 2098 last = i;
1956 } 2099 }
1957 } 2100 }
1958 output_string (printcharfun, 0, name, last, size - last); 2101 output_string (printcharfun, 0, name, last, size - last);
1959 } 2102 }
2008 return; 2151 return;
2009 2152
2010 if (alternate_do_pointer + extlen >= alternate_do_size) 2153 if (alternate_do_pointer + extlen >= alternate_do_size)
2011 { 2154 {
2012 alternate_do_size = 2155 alternate_do_size =
2013 max(alternate_do_size * 2, alternate_do_pointer + extlen + 1); 2156 max (alternate_do_size * 2, alternate_do_pointer + extlen + 1);
2014 XREALLOC_ARRAY (alternate_do_string, char, alternate_do_size); 2157 XREALLOC_ARRAY (alternate_do_string, CIbyte, alternate_do_size);
2015 } 2158 }
2016 memcpy (alternate_do_string + alternate_do_pointer, extptr, extlen); 2159 memcpy (alternate_do_string + alternate_do_pointer, extptr, extlen);
2017 alternate_do_pointer += extlen; 2160 alternate_do_pointer += extlen;
2018 alternate_do_string[alternate_do_pointer] = 0; 2161 alternate_do_string[alternate_do_pointer] = 0;
2019 } 2162 }
2126 report_file_error ("Opening termscript", filename); 2269 report_file_error ("Opening termscript", filename);
2127 } 2270 }
2128 return Qnil; 2271 return Qnil;
2129 } 2272 }
2130 2273
2274 static Lisp_Object
2275 restore_inhibit_non_essential_conversion_operations (Lisp_Object obj)
2276 {
2277 inhibit_non_essential_conversion_operations = XINT (obj);
2278 return Qnil;
2279 }
2280
2281 /* Bind the value of inhibit_non_essential_conversion_operations to 1
2282 in a way that involves no consing. */
2283 static int
2284 begin_inhibit_non_essential_conversion_operations (void)
2285 {
2286 int depth =
2287 record_unwind_protect
2288 (restore_inhibit_non_essential_conversion_operations,
2289 make_int (inhibit_non_essential_conversion_operations));
2290 inhibit_non_essential_conversion_operations = 1;
2291 return depth;
2292 }
2293
2131 static int debug_print_length = 50; 2294 static int debug_print_length = 50;
2132 static int debug_print_level = 15; 2295 static int debug_print_level = 15;
2133 static int debug_print_readably = -1; 2296 static int debug_print_readably = -1;
2134 2297
2135 /* Restore values temporarily bound by debug_prin1. We use this approach to 2298 /* Restore values temporarily bound by debug_prin1. We use this approach to
2136 avoid consing in debug_prin1. That is verboten, since debug_prin1 can be 2299 avoid consing in debug_prin1. That is verboten, since debug_print can be
2137 called by cons debugging code. */ 2300 called by cons debugging code. */
2138 static Lisp_Object 2301 static Lisp_Object
2139 debug_prin1_exit (Lisp_Object UNUSED (ignored)) 2302 debug_print_exit (Lisp_Object val)
2140 { 2303 {
2141 struct debug_bindings *bindings = 2304 struct debug_bindings *bindings =
2142 (struct debug_bindings *) XOPAQUE (debug_prin1_bindings)->data; 2305 (struct debug_bindings *) GET_VOID_FROM_LISP (val);
2143 inhibit_non_essential_conversion_operations = 2306 inhibit_non_essential_conversion_operations =
2144 bindings->inhibit_non_essential_conversion_operations; 2307 bindings->inhibit_non_essential_conversion_operations;
2145 print_depth = bindings->print_depth; 2308 print_depth = bindings->print_depth;
2146 print_readably = bindings->print_readably; 2309 print_readably = bindings->print_readably;
2147 print_unbuffered = bindings->print_unbuffered; 2310 print_unbuffered = bindings->print_unbuffered;
2311 in_debug_print = bindings->in_debug_print;
2148 gc_currently_forbidden = bindings->gc_currently_forbidden; 2312 gc_currently_forbidden = bindings->gc_currently_forbidden;
2149 Vprint_length = bindings->Vprint_length; 2313 Vprint_length = bindings->Vprint_length;
2150 Vprint_level = bindings->Vprint_level; 2314 Vprint_level = bindings->Vprint_level;
2151 Vinhibit_quit = bindings->Vinhibit_quit; 2315 Vinhibit_quit = bindings->Vinhibit_quit;
2152 return Qnil; 2316 return Qnil;
2317 }
2318
2319 /* Save values and bind them to new values suitable for debug output. We
2320 try very hard to avoid any Lisp allocation (i.e. consing) during the
2321 operation of debug printing, since we might be calling it from inside GC
2322 or other sensitive places. This means we have to be a bit careful with
2323 record_unwind_protect to not create any temporary Lisp objects. */
2324
2325 static int
2326 debug_print_enter (struct debug_bindings *bindings)
2327 {
2328 /* by doing this, we trick various things that are non-essential
2329 but might cause crashes into not getting executed. */
2330 int specdepth;
2331
2332 bindings->inhibit_non_essential_conversion_operations =
2333 inhibit_non_essential_conversion_operations;
2334 bindings->print_depth = print_depth;
2335 bindings->print_readably = print_readably;
2336 bindings->print_unbuffered = print_unbuffered;
2337 bindings->in_debug_print = in_debug_print;
2338 bindings->gc_currently_forbidden = gc_currently_forbidden;
2339 bindings->Vprint_length = Vprint_length;
2340 bindings->Vprint_level = Vprint_level;
2341 bindings->Vinhibit_quit = Vinhibit_quit;
2342 specdepth = record_unwind_protect (debug_print_exit,
2343 STORE_VOID_IN_LISP (bindings));
2344
2345 inhibit_non_essential_conversion_operations = 1;
2346 print_depth = 0;
2347 print_readably = debug_print_readably != -1 ? debug_print_readably : 0;
2348 print_unbuffered++;
2349 in_debug_print = 1;
2350 gc_currently_forbidden = 1;
2351 if (debug_print_length > 0)
2352 Vprint_length = make_int (debug_print_length);
2353 if (debug_print_level > 0)
2354 Vprint_level = make_int (debug_print_level);
2355 Vinhibit_quit = Qt;
2356
2357 return specdepth;
2153 } 2358 }
2154 2359
2155 /* Print an object, `prin1'-style, to various possible debugging outputs. 2360 /* Print an object, `prin1'-style, to various possible debugging outputs.
2156 Make sure it's completely unbuffered so that, in the event of a crash 2361 Make sure it's completely unbuffered so that, in the event of a crash
2157 somewhere, we see as much as possible that happened before it. 2362 somewhere, we see as much as possible that happened before it.
2158 */ 2363 */
2159 static void 2364 static void
2160 debug_prin1 (Lisp_Object debug_print_obj, int flags) 2365 debug_prin1 (Lisp_Object debug_print_obj, int flags)
2161 { 2366 {
2162 /* This function can GC */ 2367 /* This function cannot GC, since GC is forbidden */
2163 2368 struct debug_bindings bindings;
2164 /* by doing this, we trick various things that are non-essential 2369 int specdepth = debug_print_enter (&bindings);
2165 but might cause crashes into not getting executed. */
2166 int specdepth;
2167 struct debug_bindings *bindings =
2168 (struct debug_bindings *) XOPAQUE (debug_prin1_bindings)->data;
2169
2170 bindings->inhibit_non_essential_conversion_operations =
2171 inhibit_non_essential_conversion_operations;
2172 bindings->print_depth = print_depth;
2173 bindings->print_readably = print_readably;
2174 bindings->print_unbuffered = print_unbuffered;
2175 bindings->gc_currently_forbidden = gc_currently_forbidden;
2176 bindings->Vprint_length = Vprint_length;
2177 bindings->Vprint_level = Vprint_level;
2178 bindings->Vinhibit_quit = Vinhibit_quit;
2179 specdepth = record_unwind_protect (debug_prin1_exit, Qnil);
2180
2181 inhibit_non_essential_conversion_operations = 1;
2182 print_depth = 0;
2183 print_readably = debug_print_readably != -1 ? debug_print_readably : 0;
2184 print_unbuffered++;
2185 if (debug_print_length > 0)
2186 Vprint_length = make_int (debug_print_length);
2187 if (debug_print_level > 0)
2188 Vprint_level = make_int (debug_print_level);
2189 Vinhibit_quit = Qt;
2190 2370
2191 if ((flags & EXT_PRINT_STDOUT) || (flags & EXT_PRINT_STDERR)) 2371 if ((flags & EXT_PRINT_STDOUT) || (flags & EXT_PRINT_STDERR))
2192 print_internal (debug_print_obj, Qexternal_debugging_output, 1); 2372 print_internal (debug_print_obj, Qexternal_debugging_output, 1);
2193 if (flags & EXT_PRINT_ALTERNATE) 2373 if (flags & EXT_PRINT_ALTERNATE)
2194 print_internal (debug_print_obj, Qalternate_debugging_output, 1); 2374 print_internal (debug_print_obj, Qalternate_debugging_output, 1);
2204 } 2384 }
2205 2385
2206 void 2386 void
2207 debug_p4 (Lisp_Object obj) 2387 debug_p4 (Lisp_Object obj)
2208 { 2388 {
2209 inhibit_non_essential_conversion_operations = 1;
2210 if (STRINGP (obj)) 2389 if (STRINGP (obj))
2211 debug_out ("\"%s\"", XSTRING_DATA (obj)); 2390 debug_out ("\"%s\"", XSTRING_DATA (obj));
2212 else if (CONSP (obj)) 2391 else if (CONSP (obj))
2213 { 2392 {
2214 int first = 1; 2393 int first = 1;
2278 (EMACS_INT) (LHEADER_IMPLEMENTATION (header)->basic_p ? 2457 (EMACS_INT) (LHEADER_IMPLEMENTATION (header)->basic_p ?
2279 ((struct lrecord_header *) header)->uid : 2458 ((struct lrecord_header *) header)->uid :
2280 ((struct old_lcrecord_header *) header)->uid)); 2459 ((struct old_lcrecord_header *) header)->uid));
2281 #endif /* not NEW_GC */ 2460 #endif /* not NEW_GC */
2282 } 2461 }
2283 2462 }
2284 inhibit_non_essential_conversion_operations = 0; 2463
2285 } 2464 static int
2286
2287 static void
2288 ext_print_begin (int dest) 2465 ext_print_begin (int dest)
2289 { 2466 {
2467 int depth = begin_inhibit_non_essential_conversion_operations ();
2290 if (dest & EXT_PRINT_ALTERNATE) 2468 if (dest & EXT_PRINT_ALTERNATE)
2291 alternate_do_pointer = 0; 2469 alternate_do_pointer = 0;
2292 if (dest & (EXT_PRINT_STDERR | EXT_PRINT_STDOUT)) 2470 if (dest & (EXT_PRINT_STDERR | EXT_PRINT_STDOUT))
2293 stdout_clear_before_next_output = 1; 2471 stdout_clear_before_next_output = 1;
2472 return depth;
2294 } 2473 }
2295 2474
2296 static void 2475 static void
2297 ext_print_end (int dest) 2476 ext_print_end (int dest, int depth)
2298 { 2477 {
2299 if (dest & (EXT_PRINT_MSWINDOWS | EXT_PRINT_STDERR | EXT_PRINT_STDOUT)) 2478 if (dest & (EXT_PRINT_MSWINDOWS | EXT_PRINT_STDERR | EXT_PRINT_STDOUT))
2300 external_out (dest & (EXT_PRINT_MSWINDOWS | EXT_PRINT_STDERR | 2479 external_out (dest & (EXT_PRINT_MSWINDOWS | EXT_PRINT_STDERR |
2301 EXT_PRINT_STDOUT), "\n"); 2480 EXT_PRINT_STDOUT), "\n");
2481 unbind_to (depth);
2302 } 2482 }
2303 2483
2304 static void 2484 static void
2305 external_debug_print (Lisp_Object object, int dest) 2485 external_debug_print (Lisp_Object object, int dest)
2306 { 2486 {
2307 ext_print_begin (dest); 2487 int depth = ext_print_begin (dest);
2308 debug_prin1 (object, dest); 2488 debug_prin1 (object, dest);
2309 ext_print_end (dest); 2489 ext_print_end (dest, depth);
2310 } 2490 }
2311 2491
2312 void 2492 void
2313 debug_p3 (Lisp_Object obj) 2493 debug_p3 (Lisp_Object obj)
2314 { 2494 {
2315 debug_p4 (obj); 2495 debug_p4 (obj);
2316 inhibit_non_essential_conversion_operations = 1;
2317 debug_out ("\n"); 2496 debug_out ("\n");
2318 inhibit_non_essential_conversion_operations = 0;
2319 } 2497 }
2320 2498
2321 void 2499 void
2322 debug_print (Lisp_Object debug_print_obj) 2500 debug_print (Lisp_Object debug_print_obj)
2323 { 2501 {
2345 /* Debugging kludge -- unbuffered */ 2523 /* Debugging kludge -- unbuffered */
2346 /* This function provided for the benefit of the debugger. */ 2524 /* This function provided for the benefit of the debugger. */
2347 void 2525 void
2348 debug_backtrace (void) 2526 debug_backtrace (void)
2349 { 2527 {
2350 /* This function can GC */ 2528 /* This function cannot GC, since GC is forbidden */
2351 2529 struct debug_bindings bindings;
2352 /* by doing this, we trick various things that are non-essential 2530 int specdepth = debug_print_enter (&bindings);
2353 but might cause crashes into not getting executed. */
2354 int specdepth =
2355 internal_bind_int (&inhibit_non_essential_conversion_operations, 1);
2356
2357 internal_bind_int (&print_depth, 0);
2358 internal_bind_int (&print_readably, 0);
2359 internal_bind_int (&print_unbuffered, print_unbuffered + 1);
2360 if (debug_print_length > 0)
2361 internal_bind_lisp_object (&Vprint_length, make_int (debug_print_length));
2362 if (debug_print_level > 0)
2363 internal_bind_lisp_object (&Vprint_level, make_int (debug_print_level));
2364 /* #### Do we need this? It was in the old code. */
2365 internal_bind_lisp_object (&Vinhibit_quit, Vinhibit_quit);
2366 2531
2367 Fbacktrace (Qexternal_debugging_output, Qt); 2532 Fbacktrace (Qexternal_debugging_output, Qt);
2368 stderr_out ("\n"); 2533 stderr_out ("\n");
2369 2534
2370 unbind_to (specdepth); 2535 unbind_to (specdepth);
2381 void 2546 void
2382 debug_short_backtrace (int length) 2547 debug_short_backtrace (int length)
2383 { 2548 {
2384 int first = 1; 2549 int first = 1;
2385 struct backtrace *bt = backtrace_list; 2550 struct backtrace *bt = backtrace_list;
2551
2386 debug_out (" ["); 2552 debug_out (" [");
2387 while (length > 0 && bt) 2553 while (length > 0 && bt)
2388 { 2554 {
2389 if (!first) 2555 if (!first)
2390 { 2556 {
2560 Label for minibuffer messages created with `print'. This should 2726 Label for minibuffer messages created with `print'. This should
2561 generally be bound with `let' rather than set. (See `display-message'.) 2727 generally be bound with `let' rather than set. (See `display-message'.)
2562 */ ); 2728 */ );
2563 Vprint_message_label = Qprint; 2729 Vprint_message_label = Qprint;
2564 2730
2565 debug_prin1_bindings = 2731 /* The exact size doesn't matter since we realloc when necessary.
2566 make_opaque (OPAQUE_UNINIT, sizeof (struct debug_bindings)); 2732 Use CIbyte instead of Ibyte so that debuggers show the associated
2567 staticpro (&debug_prin1_bindings); 2733 string automatically. */
2568
2569 alternate_do_size = 5000; 2734 alternate_do_size = 5000;
2570 alternate_do_string = xnew_array(char, 5000); 2735 alternate_do_string = xnew_array (CIbyte, 5000);
2571 } 2736 }