Mercurial > hg > xemacs-beta

comparison src/print.c @ 5133:444a448b2f53

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge branch ben-lisp-object into default branch
author Ben Wing <ben@xemacs.org>
date Sun, 07 Mar 2010 06:47:37 -0600
parents a9c41067dd88
children f965e31a35f0
comparison
equal deleted inserted replaced
5113:b2dcf6a6d8ab 5133:444a448b2f53
1537 } 1537 }
1538 1538
1539 DOESNT_RETURN 1539 DOESNT_RETURN
1540 printing_unreadable_lcrecord (Lisp_Object obj, const Ibyte *name) 1540 printing_unreadable_lcrecord (Lisp_Object obj, const Ibyte *name)
1541 { 1541 {
1542 struct LCRECORD_HEADER *header = (struct LCRECORD_HEADER *) XPNTR (obj); 1542 NORMAL_LISP_OBJECT_HEADER *header = (NORMAL_LISP_OBJECT_HEADER *) XPNTR (obj);
1543 const struct lrecord_implementation *imp =
1544 XRECORD_LHEADER_IMPLEMENTATION (obj);
1543 1545
1544 #ifndef NEW_GC 1546 #ifndef NEW_GC
1545 /* This must be a real lcrecord */ 1547 /* This must be a real lcrecord */
1546 assert (!LHEADER_IMPLEMENTATION (&header->lheader)->basic_p); 1548 assert (!imp->frob_block_p);
1547 #endif 1549 #endif
1548 1550
1549 if (name) 1551 if (name)
1550 printing_unreadable_object 1552 printing_unreadable_object ("#<%s %s 0x%x>", imp->name, name, header->uid);
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 1553 else
1560 printing_unreadable_object 1554 printing_unreadable_object ("#<%s 0x%x>", imp->name, header->uid);
1561 ("#<%s 0x%x>", 1555 }
1562 #ifdef NEW_GC 1556
1563 LHEADER_IMPLEMENTATION (header)->name, 1557 void
1564 #else /* not NEW_GC */ 1558 external_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
1565 LHEADER_IMPLEMENTATION (&header->lheader)->name, 1559 int UNUSED (escapeflag))
1566 #endif /* not NEW_GC */ 1560 {
1567 header->uid); 1561 NORMAL_LISP_OBJECT_HEADER *header = (NORMAL_LISP_OBJECT_HEADER *) XPNTR (obj);
1568 } 1562 const struct lrecord_implementation *imp =
1569 1563 XRECORD_LHEADER_IMPLEMENTATION (obj);
1570 void
1571 default_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
1572 int UNUSED (escapeflag))
1573 {
1574 struct LCRECORD_HEADER *header = (struct LCRECORD_HEADER *) XPNTR (obj);
1575 1564
1576 #ifndef NEW_GC 1565 #ifndef NEW_GC
1577 /* This must be a real lcrecord */ 1566 /* This must be a real lcrecord */
1578 assert (!LHEADER_IMPLEMENTATION (&header->lheader)->basic_p); 1567 assert (!imp->frob_block_p);
1579 #endif 1568 #endif
1580 1569
1581 if (print_readably) 1570 if (print_readably)
1582 printing_unreadable_lcrecord (obj, 0); 1571 printing_unreadable_lcrecord (obj, 0);
1583 1572
1584 write_fmt_string (printcharfun, "#<%s 0x%x>", 1573 write_fmt_string (printcharfun, "#<%s 0x%x>", imp->name, header->uid);
1585 #ifdef NEW_GC
1586 LHEADER_IMPLEMENTATION (header)->name,
1587 #else /* not NEW_GC */
1588 LHEADER_IMPLEMENTATION (&header->lheader)->name,
1589 #endif /* not NEW_GC */
1590 header->uid);
1591 } 1574 }
1592 1575
1593 void 1576 void
1594 internal_object_printer (Lisp_Object obj, Lisp_Object printcharfun, 1577 internal_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
1595 int UNUSED (escapeflag)) 1578 int UNUSED (escapeflag))
1596 { 1579 {
1580 if (print_readably)
1581 printing_unreadable_object
1582 ("#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%lx>",
1583 XRECORD_LHEADER_IMPLEMENTATION (obj)->name,
1584 (unsigned long) XPNTR (obj));
1585
1597 /* Internal objects shouldn't normally escape to the Lisp level; 1586 /* Internal objects shouldn't normally escape to the Lisp level;
1598 that's why we say "XEmacs bug?". This can happen, however, when 1587 that's why we say "XEmacs bug?". This can happen, however, when
1599 printing backtraces. */ 1588 printing backtraces. */
1600 write_fmt_string (printcharfun, 1589 write_fmt_string (printcharfun,
1601 "#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%lx>", 1590 "#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%lx>",
1933 write_ascstring (printcharfun, "..."); 1922 write_ascstring (printcharfun, "...");
1934 break; 1923 break;
1935 } 1924 }
1936 } 1925 }
1937 1926
1938 if (LHEADER_IMPLEMENTATION (lheader)->printer) 1927 /* Either use a custom-written printer, or use
1939 ((LHEADER_IMPLEMENTATION (lheader)->printer) 1928 internal_object_printer or external_object_printer, depending on
1940 (obj, printcharfun, escapeflag)); 1929 whether the object is internal (not visible at Lisp level) or
1941 else 1930 external. */
1942 internal_object_printer (obj, printcharfun, escapeflag); 1931 assert (LHEADER_IMPLEMENTATION (lheader)->printer);
1932 ((LHEADER_IMPLEMENTATION (lheader)->printer)
1933 (obj, printcharfun, escapeflag));
1943 break; 1934 break;
1944 } 1935 }
1945 1936
1946 default: 1937 default:
1947 { 1938 {
2444 (EMACS_INT) ((struct lrecord_header *) header)->uid); 2435 (EMACS_INT) ((struct lrecord_header *) header)->uid);
2445 #else /* not NEW_GC */ 2436 #else /* not NEW_GC */
2446 debug_out ("#<%s addr=0x%lx uid=0x%lx>", 2437 debug_out ("#<%s addr=0x%lx uid=0x%lx>",
2447 LHEADER_IMPLEMENTATION (header)->name, 2438 LHEADER_IMPLEMENTATION (header)->name,
2448 (EMACS_INT) header, 2439 (EMACS_INT) header,
2449 (EMACS_INT) (LHEADER_IMPLEMENTATION (header)->basic_p ? 2440 (EMACS_INT) (LHEADER_IMPLEMENTATION (header)->frob_block_p ?
2450 ((struct lrecord_header *) header)->uid : 2441 ((struct lrecord_header *) header)->uid :
2451 ((struct old_lcrecord_header *) header)->uid)); 2442 ((struct old_lcrecord_header *) header)->uid));
2452 #endif /* not NEW_GC */ 2443 #endif /* not NEW_GC */
2453 } 2444 }
2454 } 2445 }