Mercurial > hg > xemacs-beta

comparison src/data.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 8626e4521993
children a86b2b5e0111
comparison
equal deleted inserted replaced
397:f4aeb21a5bad 398:74fd4e045ea6
48 Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch; 48 Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch;
49 Lisp_Object Qio_error, Qend_of_file; 49 Lisp_Object Qio_error, Qend_of_file;
50 Lisp_Object Qarith_error, Qrange_error, Qdomain_error; 50 Lisp_Object Qarith_error, Qrange_error, Qdomain_error;
51 Lisp_Object Qsingularity_error, Qoverflow_error, Qunderflow_error; 51 Lisp_Object Qsingularity_error, Qoverflow_error, Qunderflow_error;
52 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only; 52 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
53 Lisp_Object Qintegerp, Qnatnump, Qsymbolp, Qkeywordp; 53 Lisp_Object Qintegerp, Qnatnump, Qsymbolp;
54 Lisp_Object Qlistp, Qtrue_list_p, Qweak_listp; 54 Lisp_Object Qlistp, Qtrue_list_p, Qweak_listp;
55 Lisp_Object Qconsp, Qsubrp; 55 Lisp_Object Qconsp, Qsubrp;
56 Lisp_Object Qcharacterp, Qstringp, Qarrayp, Qsequencep, Qvectorp; 56 Lisp_Object Qcharacterp, Qstringp, Qarrayp, Qsequencep, Qvectorp;
57 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qbufferp; 57 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qbufferp;
58 Lisp_Object Qinteger_or_char_p, Qinteger_char_or_marker_p; 58 Lisp_Object Qinteger_or_char_p, Qinteger_char_or_marker_p;
59 Lisp_Object Qnumberp, Qnumber_or_marker_p, Qnumber_char_or_marker_p; 59 Lisp_Object Qnumberp, Qnumber_char_or_marker_p;
60 Lisp_Object Qbit_vectorp, Qbitp, Qcons, Qkeyword, Qcdr, Qignore; 60 Lisp_Object Qbit_vectorp, Qbitp, Qcdr;
61 61
62 #ifdef LISP_FLOAT_TYPE
63 Lisp_Object Qfloatp; 62 Lisp_Object Qfloatp;
64 #endif
65 63
66 #ifdef DEBUG_XEMACS 64 #ifdef DEBUG_XEMACS
67 65
68 int debug_issue_ebola_notices; 66 int debug_issue_ebola_notices;
69 67
70 int debug_ebola_backtrace_length; 68 int debug_ebola_backtrace_length;
71
72 #if 0
73 /*#ifndef LRECORD_SYMBOL*/
74 #include "backtrace.h"
75 #endif
76 69
77 int 70 int
78 eq_with_ebola_notice (Lisp_Object obj1, Lisp_Object obj2) 71 eq_with_ebola_notice (Lisp_Object obj1, Lisp_Object obj2)
79 { 72 {
80 if (debug_issue_ebola_notices != -42 /* abracadabra */ && 73 if (debug_issue_ebola_notices
81 (((CHARP (obj1) && INTP (obj2)) || (CHARP (obj2) && INTP (obj1))) 74 && ((CHARP (obj1) && INTP (obj2)) || (CHARP (obj2) && INTP (obj1))))
82 && (debug_issue_ebola_notices >= 2 75 {
83 || XCHAR_OR_INT (obj1) == XCHAR_OR_INT (obj2)))) 76 /* #### It would be really nice if this were a proper warning
84 { 77 instead of brain-dead print ro Qexternal_debugging_output. */
85 write_c_string ("Comparison between integer and character is constant nil (", 78 write_c_string ("Comparison between integer and character is constant nil (",
86 Qexternal_debugging_output); 79 Qexternal_debugging_output);
87 Fprinc (obj1, Qexternal_debugging_output); 80 Fprinc (obj1, Qexternal_debugging_output);
88 write_c_string (" and ", Qexternal_debugging_output); 81 write_c_string (" and ", Qexternal_debugging_output);
89 Fprinc (obj2, Qexternal_debugging_output); 82 Fprinc (obj2, Qexternal_debugging_output);
128 { 121 {
129 return wrong_type_argument (predicate, value); 122 return wrong_type_argument (predicate, value);
130 } 123 }
131 124
132 DOESNT_RETURN 125 DOESNT_RETURN
133 pure_write_error (Lisp_Object obj) 126 c_write_error (Lisp_Object obj)
134 { 127 {
135 signal_simple_error ("Attempt to modify read-only object", obj); 128 signal_simple_error ("Attempt to modify read-only object (c)", obj);
129 }
130
131 DOESNT_RETURN
132 lisp_write_error (Lisp_Object obj)
133 {
134 signal_simple_error ("Attempt to modify read-only object (lisp)", obj);
136 } 135 }
137 136
138 DOESNT_RETURN 137 DOESNT_RETURN
139 args_out_of_range (Lisp_Object a1, Lisp_Object a2) 138 args_out_of_range (Lisp_Object a1, Lisp_Object a2)
140 { 139 {
146 { 145 {
147 signal_error (Qargs_out_of_range, list3 (a1, a2, a3)); 146 signal_error (Qargs_out_of_range, list3 (a1, a2, a3));
148 } 147 }
149 148
150 void 149 void
151 check_int_range (int val, int min, int max) 150 check_int_range (EMACS_INT val, EMACS_INT min, EMACS_INT max)
152 { 151 {
153 if (val < min || val > max) 152 if (val < min || val > max)
154 args_out_of_range_3 (make_int (val), make_int (min), make_int (max)); 153 args_out_of_range_3 (make_int (val), make_int (min), make_int (max));
155 } 154 }
156 155
159 158
160 EMACS_INT sign_extend_temp; 159 EMACS_INT sign_extend_temp;
161 160
162 /* On a few machines, XINT can only be done by calling this. */ 161 /* On a few machines, XINT can only be done by calling this. */
163 /* XEmacs: only used by m/convex.h */ 162 /* XEmacs: only used by m/convex.h */
164 int sign_extend_lisp_int (EMACS_INT num); 163 EMACS_INT sign_extend_lisp_int (EMACS_INT num);
165 int 164 EMACS_INT
166 sign_extend_lisp_int (EMACS_INT num) 165 sign_extend_lisp_int (EMACS_INT num)
167 { 166 {
168 if (num & (1L << (VALBITS - 1))) 167 if (num & (1L << (VALBITS - 1)))
169 return num | ((-1L) << VALBITS); 168 return num | ((-1L) << VALBITS);
170 else 169 else
356 If non-nil, the return value will be a list whose first element is 355 If non-nil, the return value will be a list whose first element is
357 `interactive' and whose second element is the interactive spec. 356 `interactive' and whose second element is the interactive spec.
358 */ 357 */
359 (subr)) 358 (subr))
360 { 359 {
361 CONST char *prompt; 360 const char *prompt;
362 CHECK_SUBR (subr); 361 CHECK_SUBR (subr);
363 prompt = XSUBR (subr)->prompt; 362 prompt = XSUBR (subr)->prompt;
364 return prompt ? list2 (Qinteractive, build_string (prompt)) : Qnil; 363 return prompt ? list2 (Qinteractive, build_string (prompt)) : Qnil;
365 } 364 }
366 365
544 */ 543 */
545 (object)) 544 (object))
546 { 545 {
547 switch (XTYPE (object)) 546 switch (XTYPE (object))
548 { 547 {
549 #ifndef LRECORD_CONS
550 case Lisp_Type_Cons: return Qcons;
551 #endif
552
553 #ifndef LRECORD_SYMBOL
554 case Lisp_Type_Symbol: return Qsymbol;
555 #endif
556
557 #ifndef LRECORD_STRING
558 case Lisp_Type_String: return Qstring;
559 #endif
560
561 #ifndef LRECORD_VECTOR
562 case Lisp_Type_Vector: return Qvector;
563 #endif
564
565 case Lisp_Type_Record: 548 case Lisp_Type_Record:
566 return intern (XRECORD_LHEADER_IMPLEMENTATION (object)->name); 549 return intern (XRECORD_LHEADER_IMPLEMENTATION (object)->name);
567 550
568 case Lisp_Type_Char: return Qcharacter; 551 case Lisp_Type_Char: return Qcharacter;
569 552
630 (conscell, newcar)) 613 (conscell, newcar))
631 { 614 {
632 if (!CONSP (conscell)) 615 if (!CONSP (conscell))
633 conscell = wrong_type_argument (Qconsp, conscell); 616 conscell = wrong_type_argument (Qconsp, conscell);
634 617
635 CHECK_IMPURE (conscell);
636 XCAR (conscell) = newcar; 618 XCAR (conscell) = newcar;
637 return newcar; 619 return newcar;
638 } 620 }
639 621
640 DEFUN ("setcdr", Fsetcdr, 2, 2, 0, /* 622 DEFUN ("setcdr", Fsetcdr, 2, 2, 0, /*
643 (conscell, newcdr)) 625 (conscell, newcdr))
644 { 626 {
645 if (!CONSP (conscell)) 627 if (!CONSP (conscell))
646 conscell = wrong_type_argument (Qconsp, conscell); 628 conscell = wrong_type_argument (Qconsp, conscell);
647 629
648 CHECK_IMPURE (conscell);
649 XCDR (conscell) = newcdr; 630 XCDR (conscell) = newcdr;
650 return newcdr; 631 return newcdr;
651 } 632 }
652 633
653 /* Find the function at the end of a chain of symbol function indirections. 634 /* Find the function at the end of a chain of symbol function indirections.
677 if (EQ (hare, tortoise)) 658 if (EQ (hare, tortoise))
678 return Fsignal (Qcyclic_function_indirection, list1 (object)); 659 return Fsignal (Qcyclic_function_indirection, list1 (object));
679 } 660 }
680 661
681 if (errorp && UNBOUNDP (hare)) 662 if (errorp && UNBOUNDP (hare))
682 signal_void_function_error (object); 663 return signal_void_function_error (object);
683 664
684 return hare; 665 return hare;
685 } 666 }
686 667
687 DEFUN ("indirect-function", Findirect_function, 1, 1, 0, /* 668 DEFUN ("indirect-function", Findirect_function, 1, 1, 0, /*
704 Return the element of ARRAY at index INDEX. 685 Return the element of ARRAY at index INDEX.
705 ARRAY may be a vector, bit vector, or string. INDEX starts at 0. 686 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
706 */ 687 */
707 (array, index_)) 688 (array, index_))
708 { 689 {
709 int idx; 690 EMACS_INT idx;
710 691
711 retry: 692 retry:
712 693
713 if (INTP (index_)) idx = XINT (index_); 694 if (INTP (index_)) idx = XINT (index_);
714 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */ 695 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
758 Store into the element of ARRAY at index INDEX the value NEWVAL. 739 Store into the element of ARRAY at index INDEX the value NEWVAL.
759 ARRAY may be a vector, bit vector, or string. INDEX starts at 0. 740 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
760 */ 741 */
761 (array, index_, newval)) 742 (array, index_, newval))
762 { 743 {
763 int idx; 744 EMACS_INT idx;
764 745
765 retry: 746 retry:
766 747
767 if (INTP (index_)) idx = XINT (index_); 748 if (INTP (index_)) idx = XINT (index_);
768 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */ 749 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
771 index_ = wrong_type_argument (Qinteger_or_char_p, index_); 752 index_ = wrong_type_argument (Qinteger_or_char_p, index_);
772 goto retry; 753 goto retry;
773 } 754 }
774 755
775 if (idx < 0) goto range_error; 756 if (idx < 0) goto range_error;
776
777 CHECK_IMPURE (array);
778 757
779 if (VECTORP (array)) 758 if (VECTORP (array))
780 { 759 {
781 if (idx >= XVECTOR_LENGTH (array)) goto range_error; 760 if (idx >= XVECTOR_LENGTH (array)) goto range_error;
782 XVECTOR_DATA (array)[idx] = newval; 761 XVECTOR_DATA (array)[idx] = newval;
814 typedef struct 793 typedef struct
815 { 794 {
816 int int_p; 795 int int_p;
817 union 796 union
818 { 797 {
819 int ival; 798 EMACS_INT ival;
820 double dval; 799 double dval;
821 } c; 800 } c;
822 } int_or_double; 801 } int_or_double;
823 802
824 static void 803 static void
854 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj); 833 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
855 goto retry; 834 goto retry;
856 } 835 }
857 } 836 }
858 837
859 static int 838 static EMACS_INT
860 integer_char_or_marker_to_int (Lisp_Object obj) 839 integer_char_or_marker_to_int (Lisp_Object obj)
861 { 840 {
862 retry: 841 retry:
863 if (INTP (obj)) return XINT (obj); 842 if (INTP (obj)) return XINT (obj);
864 else if (CHARP (obj)) return XCHAR (obj); 843 else if (CHARP (obj)) return XCHAR (obj);
1431 Return remainder of first arg divided by second. 1410 Return remainder of first arg divided by second.
1432 Both must be integers, characters or markers. 1411 Both must be integers, characters or markers.
1433 */ 1412 */
1434 (num1, num2)) 1413 (num1, num2))
1435 { 1414 {
1436 int ival1 = integer_char_or_marker_to_int (num1); 1415 EMACS_INT ival1 = integer_char_or_marker_to_int (num1);
1437 int ival2 = integer_char_or_marker_to_int (num2); 1416 EMACS_INT ival2 = integer_char_or_marker_to_int (num2);
1438 1417
1439 if (ival2 == 0) 1418 if (ival2 == 0)
1440 Fsignal (Qarith_error, Qnil); 1419 Fsignal (Qarith_error, Qnil);
1441 1420
1442 return make_int (ival1 % ival2); 1421 return make_int (ival1 % ival2);
1483 1462
1484 return make_float (dval1); 1463 return make_float (dval1);
1485 } 1464 }
1486 #endif /* LISP_FLOAT_TYPE */ 1465 #endif /* LISP_FLOAT_TYPE */
1487 { 1466 {
1488 int ival; 1467 EMACS_INT ival;
1489 if (iod2.c.ival == 0) goto divide_by_zero; 1468 if (iod2.c.ival == 0) goto divide_by_zero;
1490 1469
1491 ival = iod1.c.ival % iod2.c.ival; 1470 ival = iod1.c.ival % iod2.c.ival;
1492 1471
1493 /* If the "remainder" comes out with the wrong sign, fix it. */ 1472 /* If the "remainder" comes out with the wrong sign, fix it. */
1585 static Lisp_Object Vall_weak_lists; /* Gemarke es nicht!!! */ 1564 static Lisp_Object Vall_weak_lists; /* Gemarke es nicht!!! */
1586 1565
1587 static Lisp_Object encode_weak_list_type (enum weak_list_type type); 1566 static Lisp_Object encode_weak_list_type (enum weak_list_type type);
1588 1567
1589 static Lisp_Object 1568 static Lisp_Object
1590 mark_weak_list (Lisp_Object obj, void (*markobj) (Lisp_Object)) 1569 mark_weak_list (Lisp_Object obj)
1591 { 1570 {
1592 return Qnil; /* nichts ist gemarkt */ 1571 return Qnil; /* nichts ist gemarkt */
1593 } 1572 }
1594 1573
1595 static void 1574 static void
1628 Lisp_Object 1607 Lisp_Object
1629 make_weak_list (enum weak_list_type type) 1608 make_weak_list (enum weak_list_type type)
1630 { 1609 {
1631 Lisp_Object result; 1610 Lisp_Object result;
1632 struct weak_list *wl = 1611 struct weak_list *wl =
1633 alloc_lcrecord_type (struct weak_list, lrecord_weak_list); 1612 alloc_lcrecord_type (struct weak_list, &lrecord_weak_list);
1634 1613
1635 wl->list = Qnil; 1614 wl->list = Qnil;
1636 wl->type = type; 1615 wl->type = type;
1637 XSETWEAK_LIST (result, wl); 1616 XSETWEAK_LIST (result, wl);
1638 wl->next_weak = Vall_weak_lists; 1617 wl->next_weak = Vall_weak_lists;
1639 Vall_weak_lists = result; 1618 Vall_weak_lists = result;
1640 return result; 1619 return result;
1641 } 1620 }
1642 1621
1622 static const struct lrecord_description weak_list_description[] = {
1623 { XD_LISP_OBJECT, offsetof (struct weak_list, list) },
1624 { XD_LO_LINK, offsetof (struct weak_list, next_weak) },
1625 { XD_END }
1626 };
1627
1643 DEFINE_LRECORD_IMPLEMENTATION ("weak-list", weak_list, 1628 DEFINE_LRECORD_IMPLEMENTATION ("weak-list", weak_list,
1644 mark_weak_list, print_weak_list, 1629 mark_weak_list, print_weak_list,
1645 0, weak_list_equal, weak_list_hash, 1630 0, weak_list_equal, weak_list_hash,
1631 weak_list_description,
1646 struct weak_list); 1632 struct weak_list);
1647 /* 1633 /*
1648 -- we do not mark the list elements (either the elements themselves 1634 -- we do not mark the list elements (either the elements themselves
1649 or the cons cells that hold them) in the normal marking phase. 1635 or the cons cells that hold them) in the normal marking phase.
1650 -- at the end of marking, we go through all weak lists that are 1636 -- at the end of marking, we go through all weak lists that are
1660 1646
1661 Linked lists just majorly suck, d'ya know? 1647 Linked lists just majorly suck, d'ya know?
1662 */ 1648 */
1663 1649
1664 int 1650 int
1665 finish_marking_weak_lists (int (*obj_marked_p) (Lisp_Object), 1651 finish_marking_weak_lists (void)
1666 void (*markobj) (Lisp_Object))
1667 { 1652 {
1668 Lisp_Object rest; 1653 Lisp_Object rest;
1669 int did_mark = 0; 1654 int did_mark = 0;
1670 1655
1671 for (rest = Vall_weak_lists; 1656 for (rest = Vall_weak_lists;
1672 !GC_NILP (rest); 1657 !NILP (rest);
1673 rest = XWEAK_LIST (rest)->next_weak) 1658 rest = XWEAK_LIST (rest)->next_weak)
1674 { 1659 {
1675 Lisp_Object rest2; 1660 Lisp_Object rest2;
1676 enum weak_list_type type = XWEAK_LIST (rest)->type; 1661 enum weak_list_type type = XWEAK_LIST (rest)->type;
1677 1662
1678 if (! obj_marked_p (rest)) 1663 if (! marked_p (rest))
1679 /* The weak list is probably garbage. Ignore it. */ 1664 /* The weak list is probably garbage. Ignore it. */
1680 continue; 1665 continue;
1681 1666
1682 for (rest2 = XWEAK_LIST (rest)->list; 1667 for (rest2 = XWEAK_LIST (rest)->list;
1683 /* We need to be trickier since we're inside of GC; 1668 /* We need to be trickier since we're inside of GC;
1684 use CONSP instead of !NILP in case of user-visible 1669 use CONSP instead of !NILP in case of user-visible
1685 imperfect lists */ 1670 imperfect lists */
1686 GC_CONSP (rest2); 1671 CONSP (rest2);
1687 rest2 = XCDR (rest2)) 1672 rest2 = XCDR (rest2))
1688 { 1673 {
1689 Lisp_Object elem; 1674 Lisp_Object elem;
1690 /* If the element is "marked" (meaning depends on the type 1675 /* If the element is "marked" (meaning depends on the type
1691 of weak list), we need to mark the cons containing the 1676 of weak list), we need to mark the cons containing the
1696 1681
1697 /* If a cons is already marked, then its car is already marked 1682 /* If a cons is already marked, then its car is already marked
1698 (either because of an external pointer or because of 1683 (either because of an external pointer or because of
1699 a previous call to this function), and likewise for all 1684 a previous call to this function), and likewise for all
1700 the rest of the elements in the list, so we can stop now. */ 1685 the rest of the elements in the list, so we can stop now. */
1701 if (obj_marked_p (rest2)) 1686 if (marked_p (rest2))
1702 break; 1687 break;
1703 1688
1704 elem = XCAR (rest2); 1689 elem = XCAR (rest2);
1705 1690
1706 switch (type) 1691 switch (type)
1707 { 1692 {
1708 case WEAK_LIST_SIMPLE: 1693 case WEAK_LIST_SIMPLE:
1709 if (obj_marked_p (elem)) 1694 if (marked_p (elem))
1710 need_to_mark_cons = 1; 1695 need_to_mark_cons = 1;
1711 break; 1696 break;
1712 1697
1713 case WEAK_LIST_ASSOC: 1698 case WEAK_LIST_ASSOC:
1714 if (!GC_CONSP (elem)) 1699 if (!CONSP (elem))
1715 { 1700 {
1716 /* just leave bogus elements there */ 1701 /* just leave bogus elements there */
1717 need_to_mark_cons = 1; 1702 need_to_mark_cons = 1;
1718 need_to_mark_elem = 1; 1703 need_to_mark_elem = 1;
1719 } 1704 }
1720 else if (obj_marked_p (XCAR (elem)) && 1705 else if (marked_p (XCAR (elem)) &&
1721 obj_marked_p (XCDR (elem))) 1706 marked_p (XCDR (elem)))
1722 { 1707 {
1723 need_to_mark_cons = 1; 1708 need_to_mark_cons = 1;
1724 /* We still need to mark elem, because it's 1709 /* We still need to mark elem, because it's
1725 probably not marked. */ 1710 probably not marked. */
1726 need_to_mark_elem = 1; 1711 need_to_mark_elem = 1;
1727 } 1712 }
1728 break; 1713 break;
1729 1714
1730 case WEAK_LIST_KEY_ASSOC: 1715 case WEAK_LIST_KEY_ASSOC:
1731 if (!GC_CONSP (elem)) 1716 if (!CONSP (elem))
1732 { 1717 {
1733 /* just leave bogus elements there */ 1718 /* just leave bogus elements there */
1734 need_to_mark_cons = 1; 1719 need_to_mark_cons = 1;
1735 need_to_mark_elem = 1; 1720 need_to_mark_elem = 1;
1736 } 1721 }
1737 else if (obj_marked_p (XCAR (elem))) 1722 else if (marked_p (XCAR (elem)))
1738 { 1723 {
1739 need_to_mark_cons = 1; 1724 need_to_mark_cons = 1;
1740 /* We still need to mark elem and XCDR (elem); 1725 /* We still need to mark elem and XCDR (elem);
1741 marking elem does both */ 1726 marking elem does both */
1742 need_to_mark_elem = 1; 1727 need_to_mark_elem = 1;
1743 } 1728 }
1744 break; 1729 break;
1745 1730
1746 case WEAK_LIST_VALUE_ASSOC: 1731 case WEAK_LIST_VALUE_ASSOC:
1747 if (!GC_CONSP (elem)) 1732 if (!CONSP (elem))
1748 { 1733 {
1749 /* just leave bogus elements there */ 1734 /* just leave bogus elements there */
1750 need_to_mark_cons = 1; 1735 need_to_mark_cons = 1;
1751 need_to_mark_elem = 1; 1736 need_to_mark_elem = 1;
1752 } 1737 }
1753 else if (obj_marked_p (XCDR (elem))) 1738 else if (marked_p (XCDR (elem)))
1754 { 1739 {
1755 need_to_mark_cons = 1; 1740 need_to_mark_cons = 1;
1756 /* We still need to mark elem and XCAR (elem); 1741 /* We still need to mark elem and XCAR (elem);
1757 marking elem does both */ 1742 marking elem does both */
1758 need_to_mark_elem = 1; 1743 need_to_mark_elem = 1;
1761 1746
1762 default: 1747 default:
1763 abort (); 1748 abort ();
1764 } 1749 }
1765 1750
1766 if (need_to_mark_elem && ! obj_marked_p (elem)) 1751 if (need_to_mark_elem && ! marked_p (elem))
1767 { 1752 {
1768 markobj (elem); 1753 mark_object (elem);
1769 did_mark = 1; 1754 did_mark = 1;
1770 } 1755 }
1771 1756
1772 /* We also need to mark the cons that holds the elem or 1757 /* We also need to mark the cons that holds the elem or
1773 assoc-pair. We do *not* want to call (markobj) here 1758 assoc-pair. We do *not* want to call (mark_object) here
1774 because that will mark the entire list; we just want to 1759 because that will mark the entire list; we just want to
1775 mark the cons itself. 1760 mark the cons itself.
1776 */ 1761 */
1777 if (need_to_mark_cons) 1762 if (need_to_mark_cons)
1778 { 1763 {
1779 struct Lisp_Cons *ptr = XCONS (rest2); 1764 Lisp_Cons *c = XCONS (rest2);
1780 if (!CONS_MARKED_P (ptr)) 1765 if (!CONS_MARKED_P (c))
1781 { 1766 {
1782 MARK_CONS (ptr); 1767 MARK_CONS (c);
1783 did_mark = 1; 1768 did_mark = 1;
1784 } 1769 }
1785 } 1770 }
1786 } 1771 }
1787 1772
1788 /* In case of imperfect list, need to mark the final cons 1773 /* In case of imperfect list, need to mark the final cons
1789 because we're not removing it */ 1774 because we're not removing it */
1790 if (!GC_NILP (rest2) && ! obj_marked_p (rest2)) 1775 if (!NILP (rest2) && ! marked_p (rest2))
1791 { 1776 {
1792 markobj (rest2); 1777 mark_object (rest2);
1793 did_mark = 1; 1778 did_mark = 1;
1794 } 1779 }
1795 } 1780 }
1796 1781
1797 return did_mark; 1782 return did_mark;
1798 } 1783 }
1799 1784
1800 void 1785 void
1801 prune_weak_lists (int (*obj_marked_p) (Lisp_Object)) 1786 prune_weak_lists (void)
1802 { 1787 {
1803 Lisp_Object rest, prev = Qnil; 1788 Lisp_Object rest, prev = Qnil;
1804 1789
1805 for (rest = Vall_weak_lists; 1790 for (rest = Vall_weak_lists;
1806 !GC_NILP (rest); 1791 !NILP (rest);
1807 rest = XWEAK_LIST (rest)->next_weak) 1792 rest = XWEAK_LIST (rest)->next_weak)
1808 { 1793 {
1809 if (! (obj_marked_p (rest))) 1794 if (! (marked_p (rest)))
1810 { 1795 {
1811 /* This weak list itself is garbage. Remove it from the list. */ 1796 /* This weak list itself is garbage. Remove it from the list. */
1812 if (GC_NILP (prev)) 1797 if (NILP (prev))
1813 Vall_weak_lists = XWEAK_LIST (rest)->next_weak; 1798 Vall_weak_lists = XWEAK_LIST (rest)->next_weak;
1814 else 1799 else
1815 XWEAK_LIST (prev)->next_weak = 1800 XWEAK_LIST (prev)->next_weak =
1816 XWEAK_LIST (rest)->next_weak; 1801 XWEAK_LIST (rest)->next_weak;
1817 } 1802 }
1823 1808
1824 for (rest2 = XWEAK_LIST (rest)->list, tortoise = rest2; 1809 for (rest2 = XWEAK_LIST (rest)->list, tortoise = rest2;
1825 /* We need to be trickier since we're inside of GC; 1810 /* We need to be trickier since we're inside of GC;
1826 use CONSP instead of !NILP in case of user-visible 1811 use CONSP instead of !NILP in case of user-visible
1827 imperfect lists */ 1812 imperfect lists */
1828 GC_CONSP (rest2);) 1813 CONSP (rest2);)
1829 { 1814 {
1830 /* It suffices to check the cons for marking, 1815 /* It suffices to check the cons for marking,
1831 regardless of the type of weak list: 1816 regardless of the type of weak list:
1832 1817
1833 -- if the cons is pointed to somewhere else, 1818 -- if the cons is pointed to somewhere else,
1834 then it should stay around and will be marked. 1819 then it should stay around and will be marked.
1835 -- otherwise, if it should stay around, it will 1820 -- otherwise, if it should stay around, it will
1836 have been marked in finish_marking_weak_lists(). 1821 have been marked in finish_marking_weak_lists().
1837 -- otherwise, it's not marked and should disappear. 1822 -- otherwise, it's not marked and should disappear.
1838 */ 1823 */
1839 if (! obj_marked_p (rest2)) 1824 if (! marked_p (rest2))
1840 { 1825 {
1841 /* bye bye :-( */ 1826 /* bye bye :-( */
1842 if (GC_NILP (prev2)) 1827 if (NILP (prev2))
1843 XWEAK_LIST (rest)->list = XCDR (rest2); 1828 XWEAK_LIST (rest)->list = XCDR (rest2);
1844 else 1829 else
1845 XCDR (prev2) = XCDR (rest2); 1830 XCDR (prev2) = XCDR (rest2);
1846 rest2 = XCDR (rest2); 1831 rest2 = XCDR (rest2);
1847 /* Ouch. Circularity checking is even trickier 1832 /* Ouch. Circularity checking is even trickier
1878 1863
1879 rest2 = XCDR (rest2); 1864 rest2 = XCDR (rest2);
1880 if (go_tortoise) 1865 if (go_tortoise)
1881 tortoise = XCDR (tortoise); 1866 tortoise = XCDR (tortoise);
1882 go_tortoise = !go_tortoise; 1867 go_tortoise = !go_tortoise;
1883 if (GC_EQ (rest2, tortoise)) 1868 if (EQ (rest2, tortoise))
1884 break; 1869 break;
1885 } 1870 }
1886 } 1871 }
1887 1872
1888 prev = rest; 1873 prev = rest;
2089 } 2074 }
2090 2075
2091 void 2076 void
2092 syms_of_data (void) 2077 syms_of_data (void)
2093 { 2078 {
2094 defsymbol (&Qcons, "cons");
2095 defsymbol (&Qkeyword, "keyword");
2096 defsymbol (&Qquote, "quote"); 2079 defsymbol (&Qquote, "quote");
2097 defsymbol (&Qlambda, "lambda"); 2080 defsymbol (&Qlambda, "lambda");
2098 defsymbol (&Qignore, "ignore");
2099 defsymbol (&Qlistp, "listp"); 2081 defsymbol (&Qlistp, "listp");
2100 defsymbol (&Qtrue_list_p, "true-list-p"); 2082 defsymbol (&Qtrue_list_p, "true-list-p");
2101 defsymbol (&Qconsp, "consp"); 2083 defsymbol (&Qconsp, "consp");
2102 defsymbol (&Qsubrp, "subrp"); 2084 defsymbol (&Qsubrp, "subrp");
2103 defsymbol (&Qsymbolp, "symbolp"); 2085 defsymbol (&Qsymbolp, "symbolp");
2104 defsymbol (&Qkeywordp, "keywordp");
2105 defsymbol (&Qintegerp, "integerp"); 2086 defsymbol (&Qintegerp, "integerp");
2106 defsymbol (&Qcharacterp, "characterp"); 2087 defsymbol (&Qcharacterp, "characterp");
2107 defsymbol (&Qnatnump, "natnump"); 2088 defsymbol (&Qnatnump, "natnump");
2108 defsymbol (&Qstringp, "stringp"); 2089 defsymbol (&Qstringp, "stringp");
2109 defsymbol (&Qarrayp, "arrayp"); 2090 defsymbol (&Qarrayp, "arrayp");
2116 defsymbol (&Qmarkerp, "markerp"); 2097 defsymbol (&Qmarkerp, "markerp");
2117 defsymbol (&Qinteger_or_marker_p, "integer-or-marker-p"); 2098 defsymbol (&Qinteger_or_marker_p, "integer-or-marker-p");
2118 defsymbol (&Qinteger_or_char_p, "integer-or-char-p"); 2099 defsymbol (&Qinteger_or_char_p, "integer-or-char-p");
2119 defsymbol (&Qinteger_char_or_marker_p, "integer-char-or-marker-p"); 2100 defsymbol (&Qinteger_char_or_marker_p, "integer-char-or-marker-p");
2120 defsymbol (&Qnumberp, "numberp"); 2101 defsymbol (&Qnumberp, "numberp");
2121 defsymbol (&Qnumber_or_marker_p, "number-or-marker-p");
2122 defsymbol (&Qnumber_char_or_marker_p, "number-char-or-marker-p"); 2102 defsymbol (&Qnumber_char_or_marker_p, "number-char-or-marker-p");
2123 defsymbol (&Qcdr, "cdr"); 2103 defsymbol (&Qcdr, "cdr");
2124 defsymbol (&Qweak_listp, "weak-list-p"); 2104 defsymbol (&Qweak_listp, "weak-list-p");
2125 2105
2126 #ifdef LISP_FLOAT_TYPE 2106 #ifdef LISP_FLOAT_TYPE
2215 void 2195 void
2216 vars_of_data (void) 2196 vars_of_data (void)
2217 { 2197 {
2218 /* This must not be staticpro'd */ 2198 /* This must not be staticpro'd */
2219 Vall_weak_lists = Qnil; 2199 Vall_weak_lists = Qnil;
2200 pdump_wire_list (&Vall_weak_lists);
2220 2201
2221 #ifdef DEBUG_XEMACS 2202 #ifdef DEBUG_XEMACS
2222 DEFVAR_INT ("debug-issue-ebola-notices", &debug_issue_ebola_notices /* 2203 DEFVAR_BOOL ("debug-issue-ebola-notices", &debug_issue_ebola_notices /*
2223 If non-zero, note when your code may be suffering from char-int confoundance. 2204 If non-zero, note when your code may be suffering from char-int confoundance.
2224 That is to say, if XEmacs encounters a usage of `eq', `memq', `equal', 2205 That is to say, if XEmacs encounters a usage of `eq', `memq', `equal',
2225 etc. where an int and a char with the same value are being compared, 2206 etc. where an int and a char with the same value are being compared,
2226 it will issue a notice on stderr to this effect, along with a backtrace. 2207 it will issue a notice on stderr to this effect, along with a backtrace.
2227 In such situations, the result would be different in XEmacs 19 versus 2208 In such situations, the result would be different in XEmacs 19 versus
2231 code under XEmacs 20 -- any code byte-compiled under XEmacs 19 will 2212 code under XEmacs 20 -- any code byte-compiled under XEmacs 19 will
2232 have its chars and ints all confounded in the byte code, making it 2213 have its chars and ints all confounded in the byte code, making it
2233 impossible to accurately determine Ebola infection. 2214 impossible to accurately determine Ebola infection.
2234 */ ); 2215 */ );
2235 2216
2236 debug_issue_ebola_notices = 2; /* #### temporary hack */ 2217 debug_issue_ebola_notices = 0;
2237 2218
2238 DEFVAR_INT ("debug-ebola-backtrace-length", 2219 DEFVAR_INT ("debug-ebola-backtrace-length",
2239 &debug_ebola_backtrace_length /* 2220 &debug_ebola_backtrace_length /*
2240 Length (in stack frames) of short backtrace printed out in Ebola notices. 2221 Length (in stack frames) of short backtrace printed out in Ebola notices.
2241 See `debug-issue-ebola-notices'. 2222 See `debug-issue-ebola-notices'.