Mercurial > hg > xemacs-beta

comparison src/opaque.c @ 371:cc15677e0335 r21-2b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2b1
author cvs
date Mon, 13 Aug 2007 11:03:08 +0200
parents fbbf69b4e8a7
children 8626e4521993
comparison
equal deleted inserted replaced
370:bd866891f083 371:cc15677e0335
53 Lisp_Object Vopaque_ptr_free_list; 53 Lisp_Object Vopaque_ptr_free_list;
54 54
55 static Lisp_Object 55 static Lisp_Object
56 mark_opaque (Lisp_Object obj, void (*markobj) (Lisp_Object)) 56 mark_opaque (Lisp_Object obj, void (*markobj) (Lisp_Object))
57 { 57 {
58 struct Lisp_Opaque *p = XOPAQUE (obj);
59 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
60 Lisp_Object size_or_chain = p->size_or_chain;
61 #ifdef ERROR_CHECK_GC 58 #ifdef ERROR_CHECK_GC
62 if (!in_opaque_list_marking) 59 if (!in_opaque_list_marking)
63 /* size is non-int for objects on an opaque free list. We sure 60 /* size is non-int for objects on an opaque free list. We sure
64 as hell better not be marking any of these objects unless 61 as hell better not be marking any of these objects unless
65 we're marking an opaque list. */ 62 we're marking an opaque list. */
66 assert (GC_INTP (size_or_chain)); 63 assert (INTP (XOPAQUE (obj)->size_or_chain));
67 else 64 else
68 /* marking an opaque on the free list doesn't do any recursive 65 /* marking an opaque on the free list doesn't do any recursive
69 markings, so we better not have non-freed opaques on a free 66 markings, so we better not have non-freed opaques on a free
70 list. */ 67 list. */
71 assert (!GC_INTP (size_or_chain)); 68 assert (!INTP (XOPAQUE (obj)->size_or_chain));
72 #endif 69 #endif
73 if (GC_INTP (size_or_chain) && OPAQUE_MARKFUN (p)) 70 if (INTP (XOPAQUE (obj)->size_or_chain) && XOPAQUE_MARKFUN (obj))
74 return OPAQUE_MARKFUN (p) (obj, markobj); 71 return XOPAQUE_MARKFUN (obj) (obj, markobj);
75 else 72 else
76 return size_or_chain; 73 return XOPAQUE (obj)->size_or_chain;
77 } 74 }
78 75
79 /* Should never, ever be called. (except by an external debugger) */ 76 /* Should never, ever be called. (except by an external debugger) */
80 static void 77 static void
81 print_opaque (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 78 print_opaque (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
82 { 79 {
83 CONST struct Lisp_Opaque *p = XOPAQUE (obj);
84 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
85 Lisp_Object size_or_chain = p->size_or_chain;
86 char buf[200]; 80 char buf[200];
87 if (GC_INTP (size_or_chain)) 81 if (INTP (XOPAQUE (obj)->size_or_chain))
88 sprintf (buf, "#<INTERNAL EMACS BUG (opaque, size=%ld) 0x%lx>", 82 sprintf (buf, "#<INTERNAL EMACS BUG (opaque, size=%ld) 0x%lx>",
89 (long) OPAQUE_SIZE (p), (unsigned long) XPNTR (obj)); 83 (long) XOPAQUE_SIZE (obj), (unsigned long) XPNTR (obj));
90 else 84 else
91 sprintf (buf, "#<INTERNAL EMACS BUG (opaque, freed) 0x%lx>", 85 sprintf (buf, "#<INTERNAL EMACS BUG (opaque, freed) 0x%lx>",
92 (unsigned long) XPNTR (obj)); 86 (unsigned long) XPNTR (obj));
93 write_c_string (buf, printcharfun); 87 write_c_string (buf, printcharfun);
94 } 88 }
95 89
96 static size_t 90 static size_t
97 sizeof_opaque (CONST void *header) 91 sizeof_opaque (CONST void *header)
98 { 92 {
99 CONST struct Lisp_Opaque *p = (CONST struct Lisp_Opaque *) header; 93 CONST struct Lisp_Opaque *p = (CONST struct Lisp_Opaque *) header;
100 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */ 94 if (!INTP (p->size_or_chain))
101 Lisp_Object size_or_chain = p->size_or_chain;
102 if (!GC_INTP (size_or_chain))
103 return sizeof (*p); 95 return sizeof (*p);
104 return sizeof (*p) + XINT (size_or_chain) - sizeof (int); 96 return sizeof (*p) + XINT (p->size_or_chain) - sizeof (int);
105 } 97 }
106 98
107 Lisp_Object 99 Lisp_Object
108 make_opaque (int size, CONST void *data) 100 make_opaque (int size, CONST void *data)
109 { 101 {
125 117
126 static int 118 static int
127 equal_opaque (Lisp_Object obj1, Lisp_Object obj2, int depth) 119 equal_opaque (Lisp_Object obj1, Lisp_Object obj2, int depth)
128 { 120 {
129 #ifdef DEBUG_XEMACS 121 #ifdef DEBUG_XEMACS
130 { 122 assert (!XOPAQUE_MARKFUN (obj1) && !XOPAQUE_MARKFUN (obj2));
131 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */ 123 assert (INTP (XOPAQUE(obj1)->size_or_chain));
132 Lisp_Object size_or_chain_1 = XOPAQUE (obj1)->size_or_chain; 124 assert (INTP (XOPAQUE(obj2)->size_or_chain));
133 Lisp_Object size_or_chain_2 = XOPAQUE (obj2)->size_or_chain; 125 #endif
134 assert (INTP (size_or_chain_1)); 126 if (XOPAQUE_SIZE(obj1) != XOPAQUE_SIZE(obj2))
135 assert (INTP (size_or_chain_2)); 127 return 0;
136 assert (!XOPAQUE_MARKFUN (obj1) && !XOPAQUE_MARKFUN (obj2)); 128 return (XOPAQUE_SIZE(obj1) == sizeof(*XOPAQUE_DATA(obj1))
137 } 129 ? *XOPAQUE_DATA(obj1) == *XOPAQUE_DATA(obj2)
138 #endif 130 : memcmp (XOPAQUE_DATA(obj1), XOPAQUE_DATA(obj2),
139 { 131 XOPAQUE_SIZE(obj1)) == 0);
140 size_t size;
141 return ((size = XOPAQUE_SIZE (obj1)) == XOPAQUE_SIZE (obj2) &&
142 !memcmp (XOPAQUE_DATA (obj1), XOPAQUE_DATA (obj2), size));
143 }
144 } 132 }
145 133
146 /* This will not work correctly for opaques with subobjects! */ 134 /* This will not work correctly for opaques with subobjects! */
147 135
148 static unsigned long 136 static unsigned long
149 hash_opaque (Lisp_Object obj, int depth) 137 hash_opaque (Lisp_Object obj, int depth)
150 { 138 {
151 #ifdef DEBUG_XEMACS 139 #ifdef DEBUG_XEMACS
152 { 140 assert (!XOPAQUE_MARKFUN (obj));
153 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */ 141 assert (INTP (XOPAQUE(obj)->size_or_chain));
154 Lisp_Object size_or_chain = XOPAQUE (obj)->size_or_chain; 142 #endif
155 assert (INTP (size_or_chain)); 143 if (XOPAQUE_SIZE(obj) == sizeof (unsigned long))
156 assert (!XOPAQUE_MARKFUN (obj)); 144 return (unsigned int) *XOPAQUE_DATA(obj);
157 } 145 else
158 #endif 146 return memory_hash (XOPAQUE_DATA(obj), XOPAQUE_SIZE(obj));
159 if (XOPAQUE_SIZE (obj) == sizeof (unsigned long))
160 return *((unsigned long *) XOPAQUE_DATA (obj));
161 else
162 return memory_hash (XOPAQUE_DATA (obj), XOPAQUE_SIZE (obj));
163 } 147 }
164 148
165 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque, 149 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque,
166 mark_opaque, print_opaque, 0, 150 mark_opaque, print_opaque, 0,
167 equal_opaque, hash_opaque, 151 equal_opaque, hash_opaque,
225 free_managed_opaque (Lisp_Object opaque_list, Lisp_Object opaque) 209 free_managed_opaque (Lisp_Object opaque_list, Lisp_Object opaque)
226 { 210 {
227 struct Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list); 211 struct Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list);
228 212
229 #ifdef ERROR_CHECK_GC 213 #ifdef ERROR_CHECK_GC
230 { 214 assert (INTP (XOPAQUE (opaque)->size_or_chain));
231 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
232 Lisp_Object size_or_chain = XOPAQUE (opaque)->size_or_chain;
233 assert (INTP (size_or_chain));
234 }
235 #endif 215 #endif
236 XOPAQUE (opaque)->size_or_chain = li->free; 216 XOPAQUE (opaque)->size_or_chain = li->free;
237 li->free = opaque; 217 li->free = opaque;
238 } 218 }
239 219