Mercurial > hg > xemacs-beta

comparison src/opaque.c @ 380:8626e4521993 r21-2-5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-5
author cvs
date Mon, 13 Aug 2007 11:07:10 +0200
parents cc15677e0335
children 6719134a07c2
comparison
equal deleted inserted replaced
379:76b7d63099ad 380:8626e4521993
40 */ 40 */
41 41
42 #include <config.h> 42 #include <config.h>
43 #include "lisp.h" 43 #include "lisp.h"
44 #include "opaque.h" 44 #include "opaque.h"
45 #include <stddef.h>
45 46
46 Lisp_Object Qopaquep; 47 Lisp_Object Qopaquep;
47 48
48 static int in_opaque_list_marking; 49 static int in_opaque_list_marking;
49 50
53 Lisp_Object Vopaque_ptr_free_list; 54 Lisp_Object Vopaque_ptr_free_list;
54 55
55 static Lisp_Object 56 static Lisp_Object
56 mark_opaque (Lisp_Object obj, void (*markobj) (Lisp_Object)) 57 mark_opaque (Lisp_Object obj, void (*markobj) (Lisp_Object))
57 { 58 {
59 Lisp_Opaque *p = XOPAQUE (obj);
60 Lisp_Object size_or_chain = p->size_or_chain;
58 #ifdef ERROR_CHECK_GC 61 #ifdef ERROR_CHECK_GC
59 if (!in_opaque_list_marking) 62 if (!in_opaque_list_marking)
60 /* size is non-int for objects on an opaque free list. We sure 63 /* size is non-int for objects on an opaque free list. We sure
61 as hell better not be marking any of these objects unless 64 as hell better not be marking any of these objects unless
62 we're marking an opaque list. */ 65 we're marking an opaque list. */
63 assert (INTP (XOPAQUE (obj)->size_or_chain)); 66 assert (GC_INTP (size_or_chain));
64 else 67 else
65 /* marking an opaque on the free list doesn't do any recursive 68 /* marking an opaque on the free list doesn't do any recursive
66 markings, so we better not have non-freed opaques on a free 69 markings, so we better not have non-freed opaques on a free
67 list. */ 70 list. */
68 assert (!INTP (XOPAQUE (obj)->size_or_chain)); 71 assert (!GC_INTP (size_or_chain));
69 #endif 72 #endif
70 if (INTP (XOPAQUE (obj)->size_or_chain) && XOPAQUE_MARKFUN (obj)) 73 if (GC_INTP (size_or_chain) && OPAQUE_MARKFUN (p))
71 return XOPAQUE_MARKFUN (obj) (obj, markobj); 74 return OPAQUE_MARKFUN (p) (obj, markobj);
72 else 75 else
73 return XOPAQUE (obj)->size_or_chain; 76 return size_or_chain;
74 } 77 }
75 78
76 /* Should never, ever be called. (except by an external debugger) */ 79 /* Should never, ever be called. (except by an external debugger) */
77 static void 80 static void
78 print_opaque (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 81 print_opaque (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
79 { 82 {
83 CONST Lisp_Opaque *p = XOPAQUE (obj);
80 char buf[200]; 84 char buf[200];
81 if (INTP (XOPAQUE (obj)->size_or_chain)) 85 char size_buf[50];
82 sprintf (buf, "#<INTERNAL EMACS BUG (opaque, size=%ld) 0x%lx>", 86
83 (long) XOPAQUE_SIZE (obj), (unsigned long) XPNTR (obj)); 87 if (INTP (p->size_or_chain))
84 else 88 sprintf (size_buf, "size=%lu", (unsigned long) OPAQUE_SIZE (p));
85 sprintf (buf, "#<INTERNAL EMACS BUG (opaque, freed) 0x%lx>", 89 else
86 (unsigned long) XPNTR (obj)); 90 sprintf (size_buf, "freed");
91
92 sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (opaque, %s) 0x%lx>",
93 size_buf, (unsigned long) p);
87 write_c_string (buf, printcharfun); 94 write_c_string (buf, printcharfun);
88 } 95 }
89 96
90 static size_t 97 static size_t
91 sizeof_opaque (CONST void *header) 98 sizeof_opaque (CONST void *header)
92 { 99 {
93 CONST struct Lisp_Opaque *p = (CONST struct Lisp_Opaque *) header; 100 CONST Lisp_Opaque *p = (CONST Lisp_Opaque *) header;
94 if (!INTP (p->size_or_chain)) 101 return offsetof (Lisp_Opaque, data)
95 return sizeof (*p); 102 + (GC_INTP (p->size_or_chain) ? XINT (p->size_or_chain) : 0);
96 return sizeof (*p) + XINT (p->size_or_chain) - sizeof (int); 103 }
97 } 104
98 105 /* Return an opaque object of size SIZE.
99 Lisp_Object 106 If DATA is OPAQUE_CLEAR, the object's data is memset to '\0' bytes.
100 make_opaque (int size, CONST void *data) 107 If DATA is OPAQUE_UNINIT, the object's data is uninitialized.
101 { 108 Else the object's data is initialized by copying from DATA. */
102 struct Lisp_Opaque *p = (struct Lisp_Opaque *) 109 Lisp_Object
103 alloc_lcrecord (sizeof (*p) + size - sizeof (int), lrecord_opaque); 110 make_opaque (size_t size, CONST void *data)
104 Lisp_Object val; 111 {
105 112 Lisp_Opaque *p = (Lisp_Opaque *)
113 alloc_lcrecord (offsetof (Lisp_Opaque, data) + size, lrecord_opaque);
106 p->markfun = 0; 114 p->markfun = 0;
107 p->size_or_chain = make_int (size); 115 p->size_or_chain = make_int (size);
108 if (data) 116
117 if (data == OPAQUE_CLEAR)
118 memset (p->data, '\0', size);
119 else if (data == OPAQUE_UNINIT)
120 DO_NOTHING;
121 else
109 memcpy (p->data, data, size); 122 memcpy (p->data, data, size);
110 else 123
111 memset (p->data, 0, size); 124 {
112 XSETOPAQUE (val, p); 125 Lisp_Object val;
113 return val; 126 XSETOPAQUE (val, p);
127 return val;
128 }
114 } 129 }
115 130
116 /* This will not work correctly for opaques with subobjects! */ 131 /* This will not work correctly for opaques with subobjects! */
117 132
118 static int 133 static int
119 equal_opaque (Lisp_Object obj1, Lisp_Object obj2, int depth) 134 equal_opaque (Lisp_Object obj1, Lisp_Object obj2, int depth)
120 { 135 {
136 size_t size;
121 #ifdef DEBUG_XEMACS 137 #ifdef DEBUG_XEMACS
122 assert (!XOPAQUE_MARKFUN (obj1) && !XOPAQUE_MARKFUN (obj2)); 138 assert (!XOPAQUE_MARKFUN (obj1) && !XOPAQUE_MARKFUN (obj2));
123 assert (INTP (XOPAQUE(obj1)->size_or_chain)); 139 assert (INTP (XOPAQUE (obj1)->size_or_chain));
124 assert (INTP (XOPAQUE(obj2)->size_or_chain)); 140 assert (INTP (XOPAQUE (obj2)->size_or_chain));
125 #endif 141 #endif
126 if (XOPAQUE_SIZE(obj1) != XOPAQUE_SIZE(obj2)) 142 return ((size = XOPAQUE_SIZE (obj1)) == XOPAQUE_SIZE (obj2) &&
127 return 0; 143 !memcmp (XOPAQUE_DATA (obj1), XOPAQUE_DATA (obj2), size));
128 return (XOPAQUE_SIZE(obj1) == sizeof(*XOPAQUE_DATA(obj1))
129 ? *XOPAQUE_DATA(obj1) == *XOPAQUE_DATA(obj2)
130 : memcmp (XOPAQUE_DATA(obj1), XOPAQUE_DATA(obj2),
131 XOPAQUE_SIZE(obj1)) == 0);
132 } 144 }
133 145
134 /* This will not work correctly for opaques with subobjects! */ 146 /* This will not work correctly for opaques with subobjects! */
135 147
136 static unsigned long 148 static unsigned long
137 hash_opaque (Lisp_Object obj, int depth) 149 hash_opaque (Lisp_Object obj, int depth)
138 { 150 {
139 #ifdef DEBUG_XEMACS 151 #ifdef DEBUG_XEMACS
140 assert (!XOPAQUE_MARKFUN (obj)); 152 assert (!XOPAQUE_MARKFUN (obj));
141 assert (INTP (XOPAQUE(obj)->size_or_chain)); 153 assert (INTP (XOPAQUE (obj)->size_or_chain));
142 #endif 154 #endif
143 if (XOPAQUE_SIZE(obj) == sizeof (unsigned long)) 155 if (XOPAQUE_SIZE (obj) == sizeof (unsigned long))
144 return (unsigned int) *XOPAQUE_DATA(obj); 156 return *((unsigned long *) XOPAQUE_DATA(obj));
145 else 157 else
146 return memory_hash (XOPAQUE_DATA(obj), XOPAQUE_SIZE(obj)); 158 return memory_hash (XOPAQUE_DATA (obj), XOPAQUE_SIZE (obj));
147 } 159 }
148 160
149 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque, 161 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque,
150 mark_opaque, print_opaque, 0, 162 mark_opaque, print_opaque, 0,
151 equal_opaque, hash_opaque, 163 equal_opaque, hash_opaque,
152 sizeof_opaque, struct Lisp_Opaque); 164 sizeof_opaque, Lisp_Opaque);
153 165
154 static Lisp_Object 166 static Lisp_Object
155 mark_opaque_list (Lisp_Object obj, void (*markobj) (Lisp_Object)) 167 mark_opaque_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
156 { 168 {
157 in_opaque_list_marking++; 169 in_opaque_list_marking++;
158 (markobj) (XOPAQUE_LIST (obj)->free); 170 markobj (XOPAQUE_LIST (obj)->free);
159 in_opaque_list_marking--; 171 in_opaque_list_marking--;
160 return Qnil; 172 return Qnil;
161 } 173 }
162 174
163 Lisp_Object 175 Lisp_Object
164 make_opaque_list (int size, 176 make_opaque_list (size_t size,
165 Lisp_Object (*markfun) (Lisp_Object obj, 177 Lisp_Object (*markfun) (Lisp_Object obj,
166 void (*markobj) (Lisp_Object))) 178 void (*markobj) (Lisp_Object)))
167 { 179 {
168 Lisp_Object val; 180 Lisp_Object val;
169 struct Lisp_Opaque_List *p = 181 Lisp_Opaque_List *p =
170 alloc_lcrecord_type (struct Lisp_Opaque_List, lrecord_opaque_list); 182 alloc_lcrecord_type (Lisp_Opaque_List, lrecord_opaque_list);
171 183
172 p->markfun = markfun; 184 p->markfun = markfun;
173 p->size = size; 185 p->size = size;
174 p->free = Qnil; 186 p->free = Qnil;
175 XSETOPAQUE_LIST (val, p); 187 XSETOPAQUE_LIST (val, p);
176 return val; 188 return val;
177 } 189 }
178 190
179 DEFINE_LRECORD_IMPLEMENTATION ("opaque-list", opaque_list, 191 DEFINE_LRECORD_IMPLEMENTATION ("opaque-list", opaque_list,
180 mark_opaque_list, internal_object_printer, 192 mark_opaque_list, internal_object_printer,
181 0, 0, 0, struct Lisp_Opaque_List); 193 0, 0, 0, Lisp_Opaque_List);
182 194
183 Lisp_Object 195 Lisp_Object
184 allocate_managed_opaque (Lisp_Object opaque_list, CONST void *data) 196 allocate_managed_opaque (Lisp_Object opaque_list, CONST void *data)
185 { 197 {
186 struct Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list); 198 Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list);
187 Lisp_Object val; 199 Lisp_Object val;
188 200
189 if (!NILP (li->free)) 201 if (!NILP (li->free))
190 { 202 {
191 val = li->free; 203 val = li->free;
206 } 218 }
207 219
208 void 220 void
209 free_managed_opaque (Lisp_Object opaque_list, Lisp_Object opaque) 221 free_managed_opaque (Lisp_Object opaque_list, Lisp_Object opaque)
210 { 222 {
211 struct Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list); 223 Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list);
212 224
213 #ifdef ERROR_CHECK_GC 225 #ifdef ERROR_CHECK_GC
214 assert (INTP (XOPAQUE (opaque)->size_or_chain)); 226 assert (INTP (XOPAQUE (opaque)->size_or_chain));
215 #endif 227 #endif
216 XOPAQUE (opaque)->size_or_chain = li->free; 228 XOPAQUE (opaque)->size_or_chain = li->free;
224 { 236 {
225 return allocate_managed_opaque (Vopaque_ptr_free_list, 237 return allocate_managed_opaque (Vopaque_ptr_free_list,
226 (CONST void *) &val); 238 (CONST void *) &val);
227 } 239 }
228 240
229 /* Be wery wery careful with this. Same admonitions as with 241 /* Be very very careful with this. Same admonitions as with
230 free_cons() apply. */ 242 free_cons() apply. */
231 243
232 void 244 void
233 free_opaque_ptr (Lisp_Object ptr) 245 free_opaque_ptr (Lisp_Object ptr)
234 { 246 {