Mercurial > hg > xemacs-beta

comparison src/print.c @ 5118:e0db3c197671 ben-lisp-object

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
merge up to latest default branch, doesn't compile yet
author Ben Wing <ben@xemacs.org>
date Sat, 26 Dec 2009 21:18:49 -0600
parents 3742ea8250b5 80cd90837ac5
children d1247f3cc363
comparison
equal deleted inserted replaced
5117:3742ea8250b5 5118:e0db3c197671
805 The value of the last form in BODY is returned. 805 The value of the last form in BODY is returned.
806 If BODY does not finish normally, the buffer BUFNAME is not displayed. 806 If BODY does not finish normally, the buffer BUFNAME is not displayed.
807 807
808 If variable `temp-buffer-show-function' is non-nil, call it at the end 808 If variable `temp-buffer-show-function' is non-nil, call it at the end
809 to get the buffer displayed. It gets one argument, the buffer to display. 809 to get the buffer displayed. It gets one argument, the buffer to display.
810
811 arguments: (BUFNAME &rest BODY)
810 */ 812 */
811 (args)) 813 (args))
812 { 814 {
813 /* This function can GC */ 815 /* This function can GC */
814 Lisp_Object name = Qnil; 816 Lisp_Object name = Qnil;
819 #ifdef I18N3 821 #ifdef I18N3
820 /* #### should set the buffer to be translating. See print_internal(). */ 822 /* #### should set the buffer to be translating. See print_internal(). */
821 #endif 823 #endif
822 824
823 GCPRO2 (name, val); 825 GCPRO2 (name, val);
824 name = Feval (XCAR (args)); 826 name = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args)));
825 827
826 CHECK_STRING (name); 828 CHECK_STRING (name);
827 829
828 temp_output_buffer_setup (name); 830 temp_output_buffer_setup (name);
829 UNGCPRO; 831 UNGCPRO;
865 867
866 UNGCPRO; 868 UNGCPRO;
867 return object; 869 return object;
868 } 870 }
869 871
872 Lisp_Object
873 prin1_to_string (Lisp_Object object, int noescape)
874 {
875 /* This function can GC */
876 Lisp_Object result = Qnil;
877 Lisp_Object stream = make_resizing_buffer_output_stream ();
878 Lstream *str = XLSTREAM (stream);
879 /* gcpro OBJECT in case a caller forgot to do so */
880 struct gcpro gcpro1, gcpro2, gcpro3;
881 GCPRO3 (object, stream, result);
882
883 print_internal (object, stream, !noescape);
884 Lstream_flush (str);
885 UNGCPRO;
886 result = make_string (resizing_buffer_stream_ptr (str),
887 Lstream_byte_count (str));
888 Lstream_delete (str);
889 return result;
890 }
891
870 DEFUN ("prin1-to-string", Fprin1_to_string, 1, 2, 0, /* 892 DEFUN ("prin1-to-string", Fprin1_to_string, 1, 2, 0, /*
871 Return a string containing the printed representation of OBJECT, 893 Return a string containing the printed representation of OBJECT,
872 any Lisp object. Quoting characters are used when needed to make output 894 any Lisp object. Quoting characters are used when needed to make output
873 that `read' can handle, whenever this is possible, unless the optional 895 that `read' can handle, whenever this is possible, unless the optional
874 second argument NOESCAPE is non-nil. 896 second argument NOESCAPE is non-nil.
875 */ 897 */
876 (object, noescape)) 898 (object, noescape))
877 { 899 {
878 /* This function can GC */ 900 /* This function can GC */
879 Lisp_Object result = Qnil; 901 Lisp_Object result = Qnil;
880 Lisp_Object stream = make_resizing_buffer_output_stream ();
881 Lstream *str = XLSTREAM (stream);
882 /* gcpro OBJECT in case a caller forgot to do so */
883 struct gcpro gcpro1, gcpro2, gcpro3;
884 GCPRO3 (object, stream, result);
885 902
886 RESET_PRINT_GENSYM; 903 RESET_PRINT_GENSYM;
887 print_internal (object, stream, NILP (noescape)); 904 result = prin1_to_string (object, !(EQ(noescape, Qnil)));
888 RESET_PRINT_GENSYM; 905 RESET_PRINT_GENSYM;
889 Lstream_flush (str); 906
890 UNGCPRO;
891 result = make_string (resizing_buffer_stream_ptr (str),
892 Lstream_byte_count (str));
893 Lstream_delete (str);
894 return result; 907 return result;
895 } 908 }
896 909
897 DEFUN ("princ", Fprinc, 1, 2, 0, /* 910 DEFUN ("princ", Fprinc, 1, 2, 0, /*
898 Output the printed representation of OBJECT, any Lisp object. 911 Output the printed representation of OBJECT, any Lisp object.
1267 #undef DIGITS_16 1280 #undef DIGITS_16
1268 #undef DIGITS_17 1281 #undef DIGITS_17
1269 #undef DIGITS_18 1282 #undef DIGITS_18
1270 #undef DIGITS_19 1283 #undef DIGITS_19
1271 1284
1285 void
1286 ulong_to_bit_string (char *p, unsigned long number)
1287 {
1288 int i, seen_high_order = 0;;
1289
1290 for (i = ((SIZEOF_LONG * 8) - 1); i >= 0; --i)
1291 {
1292 if (number & (unsigned long)1 << i)
1293 {
1294 seen_high_order = 1;
1295 *p++ = '1';
1296 }
1297 else
1298 {
1299 if (seen_high_order)
1300 {
1301 *p++ = '0';
1302 }
1303 }
1304 }
1305 *p = '\0';
1306 }
1307
1272 static void 1308 static void
1273 print_vector_internal (const char *start, const char *end, 1309 print_vector_internal (const char *start, const char *end,
1274 Lisp_Object obj, 1310 Lisp_Object obj,
1275 Lisp_Object printcharfun, int escapeflag) 1311 Lisp_Object printcharfun, int escapeflag)
1276 { 1312 {
1456 struct LCRECORD_HEADER *header = (struct LCRECORD_HEADER *) XPNTR (obj); 1492 struct LCRECORD_HEADER *header = (struct LCRECORD_HEADER *) XPNTR (obj);
1457 1493
1458 if (print_readably) 1494 if (print_readably)
1459 printing_unreadable_object 1495 printing_unreadable_object
1460 ("#<%s 0x%x>", 1496 ("#<%s 0x%x>",
1461 #ifdef MC_ALLOC 1497 #ifdef NEW_GC
1462 LHEADER_IMPLEMENTATION (header)->name, 1498 LHEADER_IMPLEMENTATION (header)->name,
1463 #else /* not MC_ALLOC */ 1499 #else /* not NEW_GC */
1464 LHEADER_IMPLEMENTATION (&header->lheader)->name, 1500 LHEADER_IMPLEMENTATION (&header->lheader)->name,
1465 #endif /* not MC_ALLOC */ 1501 #endif /* not NEW_GC */
1466 header->uid); 1502 header->uid);
1467 1503
1468 write_fmt_string (printcharfun, "#<%s 0x%x>", 1504 write_fmt_string (printcharfun, "#<%s 0x%x>",
1469 #ifdef MC_ALLOC 1505 #ifdef NEW_GC
1470 LHEADER_IMPLEMENTATION (header)->name, 1506 LHEADER_IMPLEMENTATION (header)->name,
1471 #else /* not MC_ALLOC */ 1507 #else /* not NEW_GC */
1472 LHEADER_IMPLEMENTATION (&header->lheader)->name, 1508 LHEADER_IMPLEMENTATION (&header->lheader)->name,
1473 #endif /* not MC_ALLOC */ 1509 #endif /* not NEW_GC */
1474 header->uid); 1510 header->uid);
1475 } 1511 }
1476 1512
1477 static void 1513 void
1478 internal_object_printer (Lisp_Object obj, Lisp_Object printcharfun, 1514 internal_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
1479 int UNUSED (escapeflag)) 1515 int UNUSED (escapeflag))
1480 { 1516 {
1481 if (print_readably) 1517 if (print_readably)
1482 printing_unreadable_object 1518 printing_unreadable_object
1483 ("#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%lx>", 1519 ("#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%lx>",
1484 XRECORD_LHEADER_IMPLEMENTATION (obj)->name, 1520 XRECORD_LHEADER_IMPLEMENTATION (obj)->name,
1485 (unsigned long) XPNTR (obj)) 1521 (unsigned long) XPNTR (obj));
1486 1522
1487 write_fmt_string (printcharfun, 1523 write_fmt_string (printcharfun,
1488 "#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%lx>", 1524 "#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%lx>",
1489 XRECORD_LHEADER_IMPLEMENTATION (obj)->name, 1525 XRECORD_LHEADER_IMPLEMENTATION (obj)->name,
1490 (unsigned long) XPNTR (obj)); 1526 (unsigned long) XPNTR (obj));
1497 BADNESS_NO_TYPE 1533 BADNESS_NO_TYPE
1498 }; 1534 };
1499 1535
1500 static void 1536 static void
1501 printing_major_badness (Lisp_Object printcharfun, 1537 printing_major_badness (Lisp_Object printcharfun,
1502 Ascbyte *badness_string, int type, void *val, 1538 const Ascbyte *badness_string, int type, void *val,
1503 enum printing_badness badness) 1539 enum printing_badness badness)
1504 { 1540 {
1505 Ibyte buf[666]; 1541 Ibyte buf[666];
1506 1542
1507 switch (badness) 1543 switch (badness)
1696 write_c_string (printcharfun, "..."); 1732 write_c_string (printcharfun, "...");
1697 break; 1733 break;
1698 } 1734 }
1699 } 1735 }
1700 1736
1701 #ifndef MC_ALLOC 1737 #ifndef NEW_GC
1702 if (lheader->type == lrecord_type_free) 1738 if (lheader->type == lrecord_type_free)
1703 { 1739 {
1704 printing_major_badness (printcharfun, "freed lrecord", 0, 1740 printing_major_badness (printcharfun, "freed lrecord", 0,
1705 lheader, BADNESS_NO_TYPE); 1741 lheader, BADNESS_NO_TYPE);
1706 break; 1742 break;
1709 { 1745 {
1710 printing_major_badness (printcharfun, "lrecord_type_undefined", 0, 1746 printing_major_badness (printcharfun, "lrecord_type_undefined", 0,
1711 lheader, BADNESS_NO_TYPE); 1747 lheader, BADNESS_NO_TYPE);
1712 break; 1748 break;
1713 } 1749 }
1714 #endif /* not MC_ALLOC */ 1750 #endif /* not NEW_GC */
1715 else if ((int) (lheader->type) >= lrecord_type_count) 1751 else if ((int) (lheader->type) >= lrecord_type_count)
1716 { 1752 {
1717 printing_major_badness (printcharfun, "illegal lrecord type", 1753 printing_major_badness (printcharfun, "illegal lrecord type",
1718 (int) (lheader->type), 1754 (int) (lheader->type),
1719 lheader, BADNESS_POINTER_OBJECT); 1755 lheader, BADNESS_POINTER_OBJECT);
1737 break; 1773 break;
1738 } 1774 }
1739 1775
1740 if (STRINGP (obj)) 1776 if (STRINGP (obj))
1741 { 1777 {
1778 #ifdef NEW_GC
1779 if (!debug_can_access_memory (XSTRING_DATA (obj),
1780 XSTRING_LENGTH (obj)))
1781 {
1782 write_fmt_string
1783 (printcharfun,
1784 "#<EMACS BUG: %p (BAD STRING DATA %p)>",
1785 lheader, XSTRING_DATA (obj));
1786 break;
1787 }
1788 #else /* not NEW_GC */
1742 Lisp_String *l = (Lisp_String *) lheader; 1789 Lisp_String *l = (Lisp_String *) lheader;
1743 if (!debug_can_access_memory (l->data_, l->size_)) 1790 if (!debug_can_access_memory (l->data_, l->size_))
1744 { 1791 {
1745 write_fmt_string 1792 write_fmt_string
1746 (printcharfun, 1793 (printcharfun,
1747 "#<EMACS BUG: %p (BAD STRING DATA %p)>", 1794 "#<EMACS BUG: %p (BAD STRING DATA %p)>",
1748 lheader, l->data_); 1795 lheader, l->data_);
1749 break; 1796 break;
1750 } 1797 }
1798 #endif /* not NEW_GC */
1751 } 1799 }
1752 } 1800 }
1753 1801
1754 if (LHEADER_IMPLEMENTATION (lheader)->printer) 1802 /* Either use a custom-written printer, or use
1755 ((LHEADER_IMPLEMENTATION (lheader)->printer) 1803 internal_object_printer or external_object_printer, depending on
1756 (obj, printcharfun, escapeflag)); 1804 whether the object is internal (not visible at Lisp level) or
1757 else 1805 external. */
1758 internal_object_printer (obj, printcharfun, escapeflag); 1806 assert (LHEADER_IMPLEMENTATION (lheader)->printer);
1807 ((LHEADER_IMPLEMENTATION (lheader)->printer)
1808 (obj, printcharfun, escapeflag));
1759 break; 1809 break;
1760 } 1810 }
1761 1811
1762 default: 1812 default:
1763 { 1813 {
2214 2264
2215 if (header->type >= lrecord_type_last_built_in_type) 2265 if (header->type >= lrecord_type_last_built_in_type)
2216 debug_out ("<< bad object type=%d 0x%lx>>", header->type, 2266 debug_out ("<< bad object type=%d 0x%lx>>", header->type,
2217 (EMACS_INT) header); 2267 (EMACS_INT) header);
2218 else 2268 else
2219 #ifdef MC_ALLOC 2269 #ifdef NEW_GC
2220 debug_out ("#<%s addr=0x%lx uid=0x%lx>", 2270 debug_out ("#<%s addr=0x%lx uid=0x%lx>",
2221 LHEADER_IMPLEMENTATION (header)->name, 2271 LHEADER_IMPLEMENTATION (header)->name,
2222 (EMACS_INT) header, 2272 (EMACS_INT) header,
2223 (EMACS_INT) ((struct lrecord_header *) header)->uid); 2273 (EMACS_INT) ((struct lrecord_header *) header)->uid);
2224 #else /* not MC_ALLOC */ 2274 #else /* not NEW_GC */
2225 debug_out ("#<%s addr=0x%lx uid=0x%lx>", 2275 debug_out ("#<%s addr=0x%lx uid=0x%lx>",
2226 LHEADER_IMPLEMENTATION (header)->name, 2276 LHEADER_IMPLEMENTATION (header)->name,
2227 (EMACS_INT) header, 2277 (EMACS_INT) header,
2228 LHEADER_IMPLEMENTATION (header)->basic_p ? 2278 (EMACS_INT) (LHEADER_IMPLEMENTATION (header)->basic_p ?
2229 ((struct lrecord_header *) header)->uid : 2279 ((struct lrecord_header *) header)->uid :
2230 ((struct old_lcrecord_header *) header)->uid); 2280 ((struct old_lcrecord_header *) header)->uid));
2231 #endif /* not MC_ALLOC */ 2281 #endif /* not NEW_GC */
2232 } 2282 }
2233 2283
2234 inhibit_non_essential_conversion_operations = 0; 2284 inhibit_non_essential_conversion_operations = 0;
2235 } 2285 }
2236 2286