Mercurial > hg > xemacs-beta

comparison src/data.c @ 412:697ef44129c6 r21-2-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-14
author cvs
date Mon, 13 Aug 2007 11:20:41 +0200
parents de805c49cfc1
children e804706bfb8c
comparison
equal deleted inserted replaced
411:12e008d41344 412:697ef44129c6
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; 53 Lisp_Object Qintegerp, Qnatnump, Qsymbolp, Qkeywordp;
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_char_or_marker_p; 59 Lisp_Object Qnumberp, Qnumber_or_marker_p, Qnumber_char_or_marker_p;
60 Lisp_Object Qbit_vectorp, Qbitp, Qcdr; 60 Lisp_Object Qbit_vectorp, Qbitp, Qcons, Qkeyword, Qcdr, Qignore;
61 61
62 Lisp_Object Qfloatp; 62 Lisp_Object Qfloatp;
63 63
64 #ifdef DEBUG_XEMACS 64 #ifdef DEBUG_XEMACS
65 65
145 { 145 {
146 signal_error (Qargs_out_of_range, list3 (a1, a2, a3)); 146 signal_error (Qargs_out_of_range, list3 (a1, a2, a3));
147 } 147 }
148 148
149 void 149 void
150 check_int_range (EMACS_INT val, EMACS_INT min, EMACS_INT max) 150 check_int_range (int val, int min, int max)
151 { 151 {
152 if (val < min || val > max) 152 if (val < min || val > max)
153 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));
154 } 154 }
155 155
158 158
159 EMACS_INT sign_extend_temp; 159 EMACS_INT sign_extend_temp;
160 160
161 /* 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. */
162 /* XEmacs: only used by m/convex.h */ 162 /* XEmacs: only used by m/convex.h */
163 EMACS_INT sign_extend_lisp_int (EMACS_INT num); 163 int sign_extend_lisp_int (EMACS_INT num);
164 EMACS_INT 164 int
165 sign_extend_lisp_int (EMACS_INT num) 165 sign_extend_lisp_int (EMACS_INT num)
166 { 166 {
167 if (num & (1L << (VALBITS - 1))) 167 if (num & (1L << (VALBITS - 1)))
168 return num | ((-1L) << VALBITS); 168 return num | ((-1L) << VALBITS);
169 else 169 else
355 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
356 `interactive' and whose second element is the interactive spec. 356 `interactive' and whose second element is the interactive spec.
357 */ 357 */
358 (subr)) 358 (subr))
359 { 359 {
360 const char *prompt; 360 CONST char *prompt;
361 CHECK_SUBR (subr); 361 CHECK_SUBR (subr);
362 prompt = XSUBR (subr)->prompt; 362 prompt = XSUBR (subr)->prompt;
363 return prompt ? list2 (Qinteractive, build_string (prompt)) : Qnil; 363 return prompt ? list2 (Qinteractive, build_string (prompt)) : Qnil;
364 } 364 }
365 365
613 (conscell, newcar)) 613 (conscell, newcar))
614 { 614 {
615 if (!CONSP (conscell)) 615 if (!CONSP (conscell))
616 conscell = wrong_type_argument (Qconsp, conscell); 616 conscell = wrong_type_argument (Qconsp, conscell);
617 617
618 CHECK_LISP_WRITEABLE (conscell);
618 XCAR (conscell) = newcar; 619 XCAR (conscell) = newcar;
619 return newcar; 620 return newcar;
620 } 621 }
621 622
622 DEFUN ("setcdr", Fsetcdr, 2, 2, 0, /* 623 DEFUN ("setcdr", Fsetcdr, 2, 2, 0, /*
625 (conscell, newcdr)) 626 (conscell, newcdr))
626 { 627 {
627 if (!CONSP (conscell)) 628 if (!CONSP (conscell))
628 conscell = wrong_type_argument (Qconsp, conscell); 629 conscell = wrong_type_argument (Qconsp, conscell);
629 630
631 CHECK_LISP_WRITEABLE (conscell);
630 XCDR (conscell) = newcdr; 632 XCDR (conscell) = newcdr;
631 return newcdr; 633 return newcdr;
632 } 634 }
633 635
634 /* Find the function at the end of a chain of symbol function indirections. 636 /* Find the function at the end of a chain of symbol function indirections.
658 if (EQ (hare, tortoise)) 660 if (EQ (hare, tortoise))
659 return Fsignal (Qcyclic_function_indirection, list1 (object)); 661 return Fsignal (Qcyclic_function_indirection, list1 (object));
660 } 662 }
661 663
662 if (errorp && UNBOUNDP (hare)) 664 if (errorp && UNBOUNDP (hare))
663 return signal_void_function_error (object); 665 signal_void_function_error (object);
664 666
665 return hare; 667 return hare;
666 } 668 }
667 669
668 DEFUN ("indirect-function", Findirect_function, 1, 1, 0, /* 670 DEFUN ("indirect-function", Findirect_function, 1, 1, 0, /*
685 Return the element of ARRAY at index INDEX. 687 Return the element of ARRAY at index INDEX.
686 ARRAY may be a vector, bit vector, or string. INDEX starts at 0. 688 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
687 */ 689 */
688 (array, index_)) 690 (array, index_))
689 { 691 {
690 EMACS_INT idx; 692 int idx;
691 693
692 retry: 694 retry:
693 695
694 if (INTP (index_)) idx = XINT (index_); 696 if (INTP (index_)) idx = XINT (index_);
695 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */ 697 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
739 Store into the element of ARRAY at index INDEX the value NEWVAL. 741 Store into the element of ARRAY at index INDEX the value NEWVAL.
740 ARRAY may be a vector, bit vector, or string. INDEX starts at 0. 742 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
741 */ 743 */
742 (array, index_, newval)) 744 (array, index_, newval))
743 { 745 {
744 EMACS_INT idx; 746 int idx;
745 747
746 retry: 748 retry:
747 749
748 if (INTP (index_)) idx = XINT (index_); 750 if (INTP (index_)) idx = XINT (index_);
749 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */ 751 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
752 index_ = wrong_type_argument (Qinteger_or_char_p, index_); 754 index_ = wrong_type_argument (Qinteger_or_char_p, index_);
753 goto retry; 755 goto retry;
754 } 756 }
755 757
756 if (idx < 0) goto range_error; 758 if (idx < 0) goto range_error;
759
760 CHECK_LISP_WRITEABLE (array);
757 761
758 if (VECTORP (array)) 762 if (VECTORP (array))
759 { 763 {
760 if (idx >= XVECTOR_LENGTH (array)) goto range_error; 764 if (idx >= XVECTOR_LENGTH (array)) goto range_error;
761 XVECTOR_DATA (array)[idx] = newval; 765 XVECTOR_DATA (array)[idx] = newval;
793 typedef struct 797 typedef struct
794 { 798 {
795 int int_p; 799 int int_p;
796 union 800 union
797 { 801 {
798 EMACS_INT ival; 802 int ival;
799 double dval; 803 double dval;
800 } c; 804 } c;
801 } int_or_double; 805 } int_or_double;
802 806
803 static void 807 static void
833 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj); 837 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
834 goto retry; 838 goto retry;
835 } 839 }
836 } 840 }
837 841
838 static EMACS_INT 842 static int
839 integer_char_or_marker_to_int (Lisp_Object obj) 843 integer_char_or_marker_to_int (Lisp_Object obj)
840 { 844 {
841 retry: 845 retry:
842 if (INTP (obj)) return XINT (obj); 846 if (INTP (obj)) return XINT (obj);
843 else if (CHARP (obj)) return XCHAR (obj); 847 else if (CHARP (obj)) return XCHAR (obj);
1062 atoi do this anyway, so we might as well make Emacs lisp consistent. */ 1066 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1063 while (*p == ' ' || *p == '\t') 1067 while (*p == ' ' || *p == '\t')
1064 p++; 1068 p++;
1065 1069
1066 #ifdef LISP_FLOAT_TYPE 1070 #ifdef LISP_FLOAT_TYPE
1067 if (isfloat_string (p) && b == 10) 1071 if (isfloat_string (p))
1068 return make_float (atof (p)); 1072 return make_float (atof (p));
1069 #endif /* LISP_FLOAT_TYPE */ 1073 #endif /* LISP_FLOAT_TYPE */
1070 1074
1071 if (b == 10) 1075 if (b == 10)
1072 { 1076 {
1410 Return remainder of first arg divided by second. 1414 Return remainder of first arg divided by second.
1411 Both must be integers, characters or markers. 1415 Both must be integers, characters or markers.
1412 */ 1416 */
1413 (num1, num2)) 1417 (num1, num2))
1414 { 1418 {
1415 EMACS_INT ival1 = integer_char_or_marker_to_int (num1); 1419 int ival1 = integer_char_or_marker_to_int (num1);
1416 EMACS_INT ival2 = integer_char_or_marker_to_int (num2); 1420 int ival2 = integer_char_or_marker_to_int (num2);
1417 1421
1418 if (ival2 == 0) 1422 if (ival2 == 0)
1419 Fsignal (Qarith_error, Qnil); 1423 Fsignal (Qarith_error, Qnil);
1420 1424
1421 return make_int (ival1 % ival2); 1425 return make_int (ival1 % ival2);
1462 1466
1463 return make_float (dval1); 1467 return make_float (dval1);
1464 } 1468 }
1465 #endif /* LISP_FLOAT_TYPE */ 1469 #endif /* LISP_FLOAT_TYPE */
1466 { 1470 {
1467 EMACS_INT ival; 1471 int ival;
1468 if (iod2.c.ival == 0) goto divide_by_zero; 1472 if (iod2.c.ival == 0) goto divide_by_zero;
1469 1473
1470 ival = iod1.c.ival % iod2.c.ival; 1474 ival = iod1.c.ival % iod2.c.ival;
1471 1475
1472 /* If the "remainder" comes out with the wrong sign, fix it. */ 1476 /* If the "remainder" comes out with the wrong sign, fix it. */
1564 static Lisp_Object Vall_weak_lists; /* Gemarke es nicht!!! */ 1568 static Lisp_Object Vall_weak_lists; /* Gemarke es nicht!!! */
1565 1569
1566 static Lisp_Object encode_weak_list_type (enum weak_list_type type); 1570 static Lisp_Object encode_weak_list_type (enum weak_list_type type);
1567 1571
1568 static Lisp_Object 1572 static Lisp_Object
1569 mark_weak_list (Lisp_Object obj) 1573 mark_weak_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
1570 { 1574 {
1571 return Qnil; /* nichts ist gemarkt */ 1575 return Qnil; /* nichts ist gemarkt */
1572 } 1576 }
1573 1577
1574 static void 1578 static void
1617 wl->next_weak = Vall_weak_lists; 1621 wl->next_weak = Vall_weak_lists;
1618 Vall_weak_lists = result; 1622 Vall_weak_lists = result;
1619 return result; 1623 return result;
1620 } 1624 }
1621 1625
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
1628 DEFINE_LRECORD_IMPLEMENTATION ("weak-list", weak_list, 1626 DEFINE_LRECORD_IMPLEMENTATION ("weak-list", weak_list,
1629 mark_weak_list, print_weak_list, 1627 mark_weak_list, print_weak_list,
1630 0, weak_list_equal, weak_list_hash, 1628 0, weak_list_equal, weak_list_hash,
1631 weak_list_description,
1632 struct weak_list); 1629 struct weak_list);
1633 /* 1630 /*
1634 -- we do not mark the list elements (either the elements themselves 1631 -- we do not mark the list elements (either the elements themselves
1635 or the cons cells that hold them) in the normal marking phase. 1632 or the cons cells that hold them) in the normal marking phase.
1636 -- at the end of marking, we go through all weak lists that are 1633 -- at the end of marking, we go through all weak lists that are
1646 1643
1647 Linked lists just majorly suck, d'ya know? 1644 Linked lists just majorly suck, d'ya know?
1648 */ 1645 */
1649 1646
1650 int 1647 int
1651 finish_marking_weak_lists (void) 1648 finish_marking_weak_lists (int (*obj_marked_p) (Lisp_Object),
1649 void (*markobj) (Lisp_Object))
1652 { 1650 {
1653 Lisp_Object rest; 1651 Lisp_Object rest;
1654 int did_mark = 0; 1652 int did_mark = 0;
1655 1653
1656 for (rest = Vall_weak_lists; 1654 for (rest = Vall_weak_lists;
1657 !NILP (rest); 1655 !GC_NILP (rest);
1658 rest = XWEAK_LIST (rest)->next_weak) 1656 rest = XWEAK_LIST (rest)->next_weak)
1659 { 1657 {
1660 Lisp_Object rest2; 1658 Lisp_Object rest2;
1661 enum weak_list_type type = XWEAK_LIST (rest)->type; 1659 enum weak_list_type type = XWEAK_LIST (rest)->type;
1662 1660
1663 if (! marked_p (rest)) 1661 if (! obj_marked_p (rest))
1664 /* The weak list is probably garbage. Ignore it. */ 1662 /* The weak list is probably garbage. Ignore it. */
1665 continue; 1663 continue;
1666 1664
1667 for (rest2 = XWEAK_LIST (rest)->list; 1665 for (rest2 = XWEAK_LIST (rest)->list;
1668 /* We need to be trickier since we're inside of GC; 1666 /* We need to be trickier since we're inside of GC;
1669 use CONSP instead of !NILP in case of user-visible 1667 use CONSP instead of !NILP in case of user-visible
1670 imperfect lists */ 1668 imperfect lists */
1671 CONSP (rest2); 1669 GC_CONSP (rest2);
1672 rest2 = XCDR (rest2)) 1670 rest2 = XCDR (rest2))
1673 { 1671 {
1674 Lisp_Object elem; 1672 Lisp_Object elem;
1675 /* If the element is "marked" (meaning depends on the type 1673 /* If the element is "marked" (meaning depends on the type
1676 of weak list), we need to mark the cons containing the 1674 of weak list), we need to mark the cons containing the
1681 1679
1682 /* If a cons is already marked, then its car is already marked 1680 /* If a cons is already marked, then its car is already marked
1683 (either because of an external pointer or because of 1681 (either because of an external pointer or because of
1684 a previous call to this function), and likewise for all 1682 a previous call to this function), and likewise for all
1685 the rest of the elements in the list, so we can stop now. */ 1683 the rest of the elements in the list, so we can stop now. */
1686 if (marked_p (rest2)) 1684 if (obj_marked_p (rest2))
1687 break; 1685 break;
1688 1686
1689 elem = XCAR (rest2); 1687 elem = XCAR (rest2);
1690 1688
1691 switch (type) 1689 switch (type)
1692 { 1690 {
1693 case WEAK_LIST_SIMPLE: 1691 case WEAK_LIST_SIMPLE:
1694 if (marked_p (elem)) 1692 if (obj_marked_p (elem))
1695 need_to_mark_cons = 1; 1693 need_to_mark_cons = 1;
1696 break; 1694 break;
1697 1695
1698 case WEAK_LIST_ASSOC: 1696 case WEAK_LIST_ASSOC:
1699 if (!CONSP (elem)) 1697 if (!GC_CONSP (elem))
1700 { 1698 {
1701 /* just leave bogus elements there */ 1699 /* just leave bogus elements there */
1702 need_to_mark_cons = 1; 1700 need_to_mark_cons = 1;
1703 need_to_mark_elem = 1; 1701 need_to_mark_elem = 1;
1704 } 1702 }
1705 else if (marked_p (XCAR (elem)) && 1703 else if (obj_marked_p (XCAR (elem)) &&
1706 marked_p (XCDR (elem))) 1704 obj_marked_p (XCDR (elem)))
1707 { 1705 {
1708 need_to_mark_cons = 1; 1706 need_to_mark_cons = 1;
1709 /* We still need to mark elem, because it's 1707 /* We still need to mark elem, because it's
1710 probably not marked. */ 1708 probably not marked. */
1711 need_to_mark_elem = 1; 1709 need_to_mark_elem = 1;
1712 } 1710 }
1713 break; 1711 break;
1714 1712
1715 case WEAK_LIST_KEY_ASSOC: 1713 case WEAK_LIST_KEY_ASSOC:
1716 if (!CONSP (elem)) 1714 if (!GC_CONSP (elem))
1717 { 1715 {
1718 /* just leave bogus elements there */ 1716 /* just leave bogus elements there */
1719 need_to_mark_cons = 1; 1717 need_to_mark_cons = 1;
1720 need_to_mark_elem = 1; 1718 need_to_mark_elem = 1;
1721 } 1719 }
1722 else if (marked_p (XCAR (elem))) 1720 else if (obj_marked_p (XCAR (elem)))
1723 { 1721 {
1724 need_to_mark_cons = 1; 1722 need_to_mark_cons = 1;
1725 /* We still need to mark elem and XCDR (elem); 1723 /* We still need to mark elem and XCDR (elem);
1726 marking elem does both */ 1724 marking elem does both */
1727 need_to_mark_elem = 1; 1725 need_to_mark_elem = 1;
1728 } 1726 }
1729 break; 1727 break;
1730 1728
1731 case WEAK_LIST_VALUE_ASSOC: 1729 case WEAK_LIST_VALUE_ASSOC:
1732 if (!CONSP (elem)) 1730 if (!GC_CONSP (elem))
1733 { 1731 {
1734 /* just leave bogus elements there */ 1732 /* just leave bogus elements there */
1735 need_to_mark_cons = 1; 1733 need_to_mark_cons = 1;
1736 need_to_mark_elem = 1; 1734 need_to_mark_elem = 1;
1737 } 1735 }
1738 else if (marked_p (XCDR (elem))) 1736 else if (obj_marked_p (XCDR (elem)))
1739 { 1737 {
1740 need_to_mark_cons = 1; 1738 need_to_mark_cons = 1;
1741 /* We still need to mark elem and XCAR (elem); 1739 /* We still need to mark elem and XCAR (elem);
1742 marking elem does both */ 1740 marking elem does both */
1743 need_to_mark_elem = 1; 1741 need_to_mark_elem = 1;
1744 } 1742 }
1745 break; 1743 break;
1746 1744
1747 case WEAK_LIST_FULL_ASSOC:
1748 if (!CONSP (elem))
1749 {
1750 /* just leave bogus elements there */
1751 need_to_mark_cons = 1;
1752 need_to_mark_elem = 1;
1753 }
1754 else if (marked_p (XCAR (elem)) ||
1755 marked_p (XCDR (elem)))
1756 {
1757 need_to_mark_cons = 1;
1758 /* We still need to mark elem and XCAR (elem);
1759 marking elem does both */
1760 need_to_mark_elem = 1;
1761 }
1762 break;
1763
1764 default: 1745 default:
1765 abort (); 1746 abort ();
1766 } 1747 }
1767 1748
1768 if (need_to_mark_elem && ! marked_p (elem)) 1749 if (need_to_mark_elem && ! obj_marked_p (elem))
1769 { 1750 {
1770 mark_object (elem); 1751 markobj (elem);
1771 did_mark = 1; 1752 did_mark = 1;
1772 } 1753 }
1773 1754
1774 /* We also need to mark the cons that holds the elem or 1755 /* We also need to mark the cons that holds the elem or
1775 assoc-pair. We do *not* want to call (mark_object) here 1756 assoc-pair. We do *not* want to call (markobj) here
1776 because that will mark the entire list; we just want to 1757 because that will mark the entire list; we just want to
1777 mark the cons itself. 1758 mark the cons itself.
1778 */ 1759 */
1779 if (need_to_mark_cons) 1760 if (need_to_mark_cons)
1780 { 1761 {
1781 Lisp_Cons *c = XCONS (rest2); 1762 struct Lisp_Cons *ptr = XCONS (rest2);
1782 if (!CONS_MARKED_P (c)) 1763 if (!CONS_MARKED_P (ptr))
1783 { 1764 {
1784 MARK_CONS (c); 1765 MARK_CONS (ptr);
1785 did_mark = 1; 1766 did_mark = 1;
1786 } 1767 }
1787 } 1768 }
1788 } 1769 }
1789 1770
1790 /* In case of imperfect list, need to mark the final cons 1771 /* In case of imperfect list, need to mark the final cons
1791 because we're not removing it */ 1772 because we're not removing it */
1792 if (!NILP (rest2) && ! marked_p (rest2)) 1773 if (!GC_NILP (rest2) && ! obj_marked_p (rest2))
1793 { 1774 {
1794 mark_object (rest2); 1775 markobj (rest2);
1795 did_mark = 1; 1776 did_mark = 1;
1796 } 1777 }
1797 } 1778 }
1798 1779
1799 return did_mark; 1780 return did_mark;
1800 } 1781 }
1801 1782
1802 void 1783 void
1803 prune_weak_lists (void) 1784 prune_weak_lists (int (*obj_marked_p) (Lisp_Object))
1804 { 1785 {
1805 Lisp_Object rest, prev = Qnil; 1786 Lisp_Object rest, prev = Qnil;
1806 1787
1807 for (rest = Vall_weak_lists; 1788 for (rest = Vall_weak_lists;
1808 !NILP (rest); 1789 !GC_NILP (rest);
1809 rest = XWEAK_LIST (rest)->next_weak) 1790 rest = XWEAK_LIST (rest)->next_weak)
1810 { 1791 {
1811 if (! (marked_p (rest))) 1792 if (! (obj_marked_p (rest)))
1812 { 1793 {
1813 /* This weak list itself is garbage. Remove it from the list. */ 1794 /* This weak list itself is garbage. Remove it from the list. */
1814 if (NILP (prev)) 1795 if (GC_NILP (prev))
1815 Vall_weak_lists = XWEAK_LIST (rest)->next_weak; 1796 Vall_weak_lists = XWEAK_LIST (rest)->next_weak;
1816 else 1797 else
1817 XWEAK_LIST (prev)->next_weak = 1798 XWEAK_LIST (prev)->next_weak =
1818 XWEAK_LIST (rest)->next_weak; 1799 XWEAK_LIST (rest)->next_weak;
1819 } 1800 }
1825 1806
1826 for (rest2 = XWEAK_LIST (rest)->list, tortoise = rest2; 1807 for (rest2 = XWEAK_LIST (rest)->list, tortoise = rest2;
1827 /* We need to be trickier since we're inside of GC; 1808 /* We need to be trickier since we're inside of GC;
1828 use CONSP instead of !NILP in case of user-visible 1809 use CONSP instead of !NILP in case of user-visible
1829 imperfect lists */ 1810 imperfect lists */
1830 CONSP (rest2);) 1811 GC_CONSP (rest2);)
1831 { 1812 {
1832 /* It suffices to check the cons for marking, 1813 /* It suffices to check the cons for marking,
1833 regardless of the type of weak list: 1814 regardless of the type of weak list:
1834 1815
1835 -- if the cons is pointed to somewhere else, 1816 -- if the cons is pointed to somewhere else,
1836 then it should stay around and will be marked. 1817 then it should stay around and will be marked.
1837 -- otherwise, if it should stay around, it will 1818 -- otherwise, if it should stay around, it will
1838 have been marked in finish_marking_weak_lists(). 1819 have been marked in finish_marking_weak_lists().
1839 -- otherwise, it's not marked and should disappear. 1820 -- otherwise, it's not marked and should disappear.
1840 */ 1821 */
1841 if (! marked_p (rest2)) 1822 if (! obj_marked_p (rest2))
1842 { 1823 {
1843 /* bye bye :-( */ 1824 /* bye bye :-( */
1844 if (NILP (prev2)) 1825 if (GC_NILP (prev2))
1845 XWEAK_LIST (rest)->list = XCDR (rest2); 1826 XWEAK_LIST (rest)->list = XCDR (rest2);
1846 else 1827 else
1847 XCDR (prev2) = XCDR (rest2); 1828 XCDR (prev2) = XCDR (rest2);
1848 rest2 = XCDR (rest2); 1829 rest2 = XCDR (rest2);
1849 /* Ouch. Circularity checking is even trickier 1830 /* Ouch. Circularity checking is even trickier
1880 1861
1881 rest2 = XCDR (rest2); 1862 rest2 = XCDR (rest2);
1882 if (go_tortoise) 1863 if (go_tortoise)
1883 tortoise = XCDR (tortoise); 1864 tortoise = XCDR (tortoise);
1884 go_tortoise = !go_tortoise; 1865 go_tortoise = !go_tortoise;
1885 if (EQ (rest2, tortoise)) 1866 if (GC_EQ (rest2, tortoise))
1886 break; 1867 break;
1887 } 1868 }
1888 } 1869 }
1889 1870
1890 prev = rest; 1871 prev = rest;
1899 if (EQ (symbol, Qsimple)) return WEAK_LIST_SIMPLE; 1880 if (EQ (symbol, Qsimple)) return WEAK_LIST_SIMPLE;
1900 if (EQ (symbol, Qassoc)) return WEAK_LIST_ASSOC; 1881 if (EQ (symbol, Qassoc)) return WEAK_LIST_ASSOC;
1901 if (EQ (symbol, Qold_assoc)) return WEAK_LIST_ASSOC; /* EBOLA ALERT! */ 1882 if (EQ (symbol, Qold_assoc)) return WEAK_LIST_ASSOC; /* EBOLA ALERT! */
1902 if (EQ (symbol, Qkey_assoc)) return WEAK_LIST_KEY_ASSOC; 1883 if (EQ (symbol, Qkey_assoc)) return WEAK_LIST_KEY_ASSOC;
1903 if (EQ (symbol, Qvalue_assoc)) return WEAK_LIST_VALUE_ASSOC; 1884 if (EQ (symbol, Qvalue_assoc)) return WEAK_LIST_VALUE_ASSOC;
1904 if (EQ (symbol, Qfull_assoc)) return WEAK_LIST_FULL_ASSOC;
1905 1885
1906 signal_simple_error ("Invalid weak list type", symbol); 1886 signal_simple_error ("Invalid weak list type", symbol);
1907 return WEAK_LIST_SIMPLE; /* not reached */ 1887 return WEAK_LIST_SIMPLE; /* not reached */
1908 } 1888 }
1909 1889
1914 { 1894 {
1915 case WEAK_LIST_SIMPLE: return Qsimple; 1895 case WEAK_LIST_SIMPLE: return Qsimple;
1916 case WEAK_LIST_ASSOC: return Qassoc; 1896 case WEAK_LIST_ASSOC: return Qassoc;
1917 case WEAK_LIST_KEY_ASSOC: return Qkey_assoc; 1897 case WEAK_LIST_KEY_ASSOC: return Qkey_assoc;
1918 case WEAK_LIST_VALUE_ASSOC: return Qvalue_assoc; 1898 case WEAK_LIST_VALUE_ASSOC: return Qvalue_assoc;
1919 case WEAK_LIST_FULL_ASSOC: return Qfull_assoc;
1920 default: 1899 default:
1921 abort (); 1900 abort ();
1922 } 1901 }
1923 1902
1924 return Qnil; /* not reached */ 1903 return Qnil; /* not reached */
1953 pointed to. 1932 pointed to.
1954 `key-assoc' Objects in the list disappear if they are conses 1933 `key-assoc' Objects in the list disappear if they are conses
1955 and the car is not pointed to. 1934 and the car is not pointed to.
1956 `value-assoc' Objects in the list disappear if they are conses 1935 `value-assoc' Objects in the list disappear if they are conses
1957 and the cdr is not pointed to. 1936 and the cdr is not pointed to.
1958 `full-assoc' Objects in the list disappear if they are conses
1959 and neither the car nor the cdr is pointed to.
1960 */ 1937 */
1961 (type)) 1938 (type))
1962 { 1939 {
1963 if (NILP (type)) 1940 if (NILP (type))
1964 type = Qsimple; 1941 type = Qsimple;
2095 } 2072 }
2096 2073
2097 void 2074 void
2098 syms_of_data (void) 2075 syms_of_data (void)
2099 { 2076 {
2100 INIT_LRECORD_IMPLEMENTATION (weak_list); 2077 defsymbol (&Qcons, "cons");
2101 2078 defsymbol (&Qkeyword, "keyword");
2102 defsymbol (&Qquote, "quote"); 2079 defsymbol (&Qquote, "quote");
2103 defsymbol (&Qlambda, "lambda"); 2080 defsymbol (&Qlambda, "lambda");
2081 defsymbol (&Qignore, "ignore");
2104 defsymbol (&Qlistp, "listp"); 2082 defsymbol (&Qlistp, "listp");
2105 defsymbol (&Qtrue_list_p, "true-list-p"); 2083 defsymbol (&Qtrue_list_p, "true-list-p");
2106 defsymbol (&Qconsp, "consp"); 2084 defsymbol (&Qconsp, "consp");
2107 defsymbol (&Qsubrp, "subrp"); 2085 defsymbol (&Qsubrp, "subrp");
2108 defsymbol (&Qsymbolp, "symbolp"); 2086 defsymbol (&Qsymbolp, "symbolp");
2087 defsymbol (&Qkeywordp, "keywordp");
2109 defsymbol (&Qintegerp, "integerp"); 2088 defsymbol (&Qintegerp, "integerp");
2110 defsymbol (&Qcharacterp, "characterp"); 2089 defsymbol (&Qcharacterp, "characterp");
2111 defsymbol (&Qnatnump, "natnump"); 2090 defsymbol (&Qnatnump, "natnump");
2112 defsymbol (&Qstringp, "stringp"); 2091 defsymbol (&Qstringp, "stringp");
2113 defsymbol (&Qarrayp, "arrayp"); 2092 defsymbol (&Qarrayp, "arrayp");
2120 defsymbol (&Qmarkerp, "markerp"); 2099 defsymbol (&Qmarkerp, "markerp");
2121 defsymbol (&Qinteger_or_marker_p, "integer-or-marker-p"); 2100 defsymbol (&Qinteger_or_marker_p, "integer-or-marker-p");
2122 defsymbol (&Qinteger_or_char_p, "integer-or-char-p"); 2101 defsymbol (&Qinteger_or_char_p, "integer-or-char-p");
2123 defsymbol (&Qinteger_char_or_marker_p, "integer-char-or-marker-p"); 2102 defsymbol (&Qinteger_char_or_marker_p, "integer-char-or-marker-p");
2124 defsymbol (&Qnumberp, "numberp"); 2103 defsymbol (&Qnumberp, "numberp");
2104 defsymbol (&Qnumber_or_marker_p, "number-or-marker-p");
2125 defsymbol (&Qnumber_char_or_marker_p, "number-char-or-marker-p"); 2105 defsymbol (&Qnumber_char_or_marker_p, "number-char-or-marker-p");
2126 defsymbol (&Qcdr, "cdr"); 2106 defsymbol (&Qcdr, "cdr");
2127 defsymbol (&Qweak_listp, "weak-list-p"); 2107 defsymbol (&Qweak_listp, "weak-list-p");
2128 2108
2129 #ifdef LISP_FLOAT_TYPE 2109 #ifdef LISP_FLOAT_TYPE
2218 void 2198 void
2219 vars_of_data (void) 2199 vars_of_data (void)
2220 { 2200 {
2221 /* This must not be staticpro'd */ 2201 /* This must not be staticpro'd */
2222 Vall_weak_lists = Qnil; 2202 Vall_weak_lists = Qnil;
2223 pdump_wire_list (&Vall_weak_lists);
2224 2203
2225 #ifdef DEBUG_XEMACS 2204 #ifdef DEBUG_XEMACS
2226 DEFVAR_BOOL ("debug-issue-ebola-notices", &debug_issue_ebola_notices /* 2205 DEFVAR_BOOL ("debug-issue-ebola-notices", &debug_issue_ebola_notices /*
2227 If non-zero, note when your code may be suffering from char-int confoundance. 2206 If non-zero, note when your code may be suffering from char-int confoundance.
2228 That is to say, if XEmacs encounters a usage of `eq', `memq', `equal', 2207 That is to say, if XEmacs encounters a usage of `eq', `memq', `equal',