Mercurial > hg > xemacs-beta

comparison src/lrecord.h @ 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
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, 19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */ 20 Boston, MA 02111-1307, USA. */
21 21
22 /* Synched up with: Not in FSF. */ 22 /* Synched up with: Not in FSF. */
23 23
24 #ifndef _XEMACS_LRECORD_H_ 24 #ifndef INCLUDED_lrecord_h_
25 #define _XEMACS_LRECORD_H_ 25 #define INCLUDED_lrecord_h_
26 26
27 /* The "lrecord" type of Lisp object is used for all object types 27 /* The "lrecord" type of Lisp object is used for all object types
28 other than a few simple ones. This allows many types to be 28 other than a few simple ones. This allows many types to be
29 implemented but only a few bits required in a Lisp object for 29 implemented but only a few bits required in a Lisp object for type
30 type information. (The tradeoff is that each object has its 30 information. (The tradeoff is that each object has its type marked
31 type marked in it, thereby increasing its size.) The first 31 in it, thereby increasing its size.) All lrecords begin with a
32 four bytes of all lrecords is either a pointer to a struct 32 `struct lrecord_header', which identifies the lisp object type, by
33 lrecord_implementation, which contains methods describing how 33 providing an index into a table of `struct lrecord_implementation',
34 to process this object, or an index into an array of pointers 34 which describes the behavior of the lisp object. It also contains
35 to struct lrecord_implementations plus some other data bits. 35 some other data bits.
36 36
37 Lrecords are of two types: straight lrecords, and lcrecords. 37 Lrecords are of two types: straight lrecords, and lcrecords.
38 Straight lrecords are used for those types of objects that have 38 Straight lrecords are used for those types of objects that have
39 their own allocation routines (typically allocated out of 2K chunks 39 their own allocation routines (typically allocated out of 2K chunks
40 of memory called `frob blocks'). These objects have a `struct 40 of memory called `frob blocks'). These objects have a `struct
41 lrecord_header' at the top, containing only the bits needed to find 41 lrecord_header' at the top, containing only the bits needed to find
42 the lrecord_implementation for the object. There are special 42 the lrecord_implementation for the object. There are special
43 routines in alloc.c to deal with each such object type. 43 routines in alloc.c to deal with each such object type.
44 44
45 Lcrecords are used for less common sorts of objects that don't 45 Lcrecords are used for less common sorts of objects that don't do
46 do their own allocation. Each such object is malloc()ed 46 their own allocation. Each such object is malloc()ed individually,
47 individually, and the objects are chained together through 47 and the objects are chained together through a `next' pointer.
48 a `next' pointer. Lcrecords have a `struct lcrecord_header' 48 Lcrecords have a `struct lcrecord_header' at the top, which
49 at the top, which contains a `struct lrecord_header' and 49 contains a `struct lrecord_header' and a `next' pointer, and are
50 a `next' pointer, and are allocated using alloc_lcrecord(). 50 allocated using alloc_lcrecord().
51 51
52 Creating a new lcrecord type is fairly easy; just follow the 52 Creating a new lcrecord type is fairly easy; just follow the
53 lead of some existing type (e.g. hash tables). Note that you 53 lead of some existing type (e.g. hash tables). Note that you
54 do not need to supply all the methods (see below); reasonable 54 do not need to supply all the methods (see below); reasonable
55 defaults are provided for many of them. Alternatively, if you're 55 defaults are provided for many of them. Alternatively, if you're
57 could contain Lisp_Objects in it), you may well be able to use 57 could contain Lisp_Objects in it), you may well be able to use
58 the opaque type. */ 58 the opaque type. */
59 59
60 struct lrecord_header 60 struct lrecord_header
61 { 61 {
62 /* It would be better to put the mark-bit together with the
63 following datatype identification field in an 8- or 16-bit
64 integer rather than playing funny games with changing
65 header->implementation and "wasting" 32 bits on the below
66 pointer. The type-id would then be a 7 or 15 bit index into a
67 table of lrecord-implementations rather than a direct pointer.
68 There would be 24 (or 16) bits left over for datatype-specific
69 per-instance flags.
70
71 The below is the simplest thing to do for the present,
72 and doesn't incur that much overhead as most Emacs records
73 are of such a size that the overhead isn't too bad.
74 (The marker datatype is the worst case.)
75
76 It also has the very very very slight advantage that type-checking
77 involves one memory read (of the "implementation" slot) and a
78 comparison against a link-time constant address rather than a
79 read and a comparison against a variable value. (Variable since
80 it is a very good idea to assign the indices into the hypothetical
81 type-code table dynamically rather that pre-defining them.)
82 I think I remember that Elk Lisp does something like this.
83 Gee, I wonder if some cretin has patented it? */
84
85 /*
86 * If USE_INDEXED_LRECORD_IMPLEMENTATION is defined, we are
87 * implementing the scheme described in the 'It would be better
88 * ...' paragraph above.
89 */
90 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
91 /* index into lrecord_implementations_table[] */ 62 /* index into lrecord_implementations_table[] */
92 unsigned char type; 63 unsigned int type :8;
93 /* 1 if the object is marked during GC, 0 otherwise. */ 64 /* 1 if the object is marked during GC. */
94 char mark; 65 unsigned int mark :1;
95 /* 1 if the object resides in pure (read-only) space */ 66 /* 1 if the object resides in read-only space */
96 char pure; 67 unsigned int c_readonly :1;
97 #else 68 /* 1 if the object is readonly from lisp */
98 CONST struct lrecord_implementation *implementation; 69 unsigned int lisp_readonly :1;
99 #endif
100 }; 70 };
101 71
102 struct lrecord_implementation; 72 struct lrecord_implementation;
103 int lrecord_type_index (CONST struct lrecord_implementation *implementation); 73 int lrecord_type_index (const struct lrecord_implementation *implementation);
104 74
105 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION 75 #define set_lheader_implementation(header,imp) do { \
106 # define set_lheader_implementation(header,imp) do { \
107 struct lrecord_header* SLI_header = (header); \ 76 struct lrecord_header* SLI_header = (header); \
108 (SLI_header)->type = lrecord_type_index (imp); \ 77 SLI_header->type = lrecord_type_index (imp); \
109 (SLI_header)->mark = 0; \ 78 SLI_header->mark = 0; \
110 (SLI_header)->pure = 0; \ 79 SLI_header->c_readonly = 0; \
80 SLI_header->lisp_readonly = 0; \
111 } while (0) 81 } while (0)
112 #else
113 # define set_lheader_implementation(header,imp) \
114 ((void) ((header)->implementation = (imp)))
115 #endif
116 82
117 struct lcrecord_header 83 struct lcrecord_header
118 { 84 {
119 struct lrecord_header lheader; 85 struct lrecord_header lheader;
120 86
121 /* The `next' field is normally used to chain all lrecords together 87 /* The `next' field is normally used to chain all lcrecords together
122 so that the GC can find (and free) all of them. 88 so that the GC can find (and free) all of them.
123 `alloc_lcrecord' threads records together. 89 `alloc_lcrecord' threads lcrecords together.
124 90
125 The `next' field may be used for other purposes as long as some 91 The `next' field may be used for other purposes as long as some
126 other mechanism is provided for letting the GC do its work. 92 other mechanism is provided for letting the GC do its work.
127 93
128 For example, the event and marker object types allocate members 94 For example, the event and marker object types allocate members
150 { 116 {
151 struct lcrecord_header lcheader; 117 struct lcrecord_header lcheader;
152 Lisp_Object chain; 118 Lisp_Object chain;
153 }; 119 };
154 120
155 /* This as the value of lheader->implementation->finalizer
156 means that this record is already marked */
157 void this_marks_a_marked_record (void *, int);
158
159 /* see alloc.c for an explanation */ 121 /* see alloc.c for an explanation */
160 Lisp_Object this_one_is_unmarkable (Lisp_Object obj, 122 Lisp_Object this_one_is_unmarkable (Lisp_Object obj);
161 void (*markobj) (Lisp_Object));
162 123
163 struct lrecord_implementation 124 struct lrecord_implementation
164 { 125 {
165 CONST char *name; 126 const char *name;
166 /* This function is called at GC time, to make sure that all Lisp_Objects 127
128 /* `marker' is called at GC time, to make sure that all Lisp_Objects
167 pointed to by this object get properly marked. It should call 129 pointed to by this object get properly marked. It should call
168 the mark_object function on all Lisp_Objects in the object. If 130 the mark_object function on all Lisp_Objects in the object. If
169 the return value is non-nil, it should be a Lisp_Object to be 131 the return value is non-nil, it should be a Lisp_Object to be
170 marked (don't call the mark_object function explicitly on it, 132 marked (don't call the mark_object function explicitly on it,
171 because the GC routines will do this). Doing it this way reduces 133 because the GC routines will do this). Doing it this way reduces
172 recursion, so the object returned should preferably be the one 134 recursion, so the object returned should preferably be the one
173 with the deepest level of Lisp_Object pointers. This function 135 with the deepest level of Lisp_Object pointers. This function
174 can be NULL, meaning no GC marking is necessary. */ 136 can be NULL, meaning no GC marking is necessary. */
175 Lisp_Object (*marker) (Lisp_Object, void (*mark_object) (Lisp_Object)); 137 Lisp_Object (*marker) (Lisp_Object);
176 /* This can be NULL if the object is an lcrecord; the 138
177 default_object_printer() in print.c will be used. */ 139 /* `printer' converts the object to a printed representation.
140 This can be NULL; in this case default_object_printer() will be
141 used instead. */
178 void (*printer) (Lisp_Object, Lisp_Object printcharfun, int escapeflag); 142 void (*printer) (Lisp_Object, Lisp_Object printcharfun, int escapeflag);
179 /* This function is called at GC time when the object is about to 143
144 /* `finalizer' is called at GC time when the object is about to
180 be freed, and at dump time (FOR_DISKSAVE will be non-zero in this 145 be freed, and at dump time (FOR_DISKSAVE will be non-zero in this
181 case). It should perform any necessary cleanup (e.g. freeing 146 case). It should perform any necessary cleanup (e.g. freeing
182 malloc()ed memory. This can be NULL, meaning no special 147 malloc()ed memory). This can be NULL, meaning no special
183 finalization is necessary. 148 finalization is necessary.
184 149
185 WARNING: remember that the finalizer is called at dump time even 150 WARNING: remember that `finalizer' is called at dump time even
186 though the object is not being freed. */ 151 though the object is not being freed. */
187 void (*finalizer) (void *header, int for_disksave); 152 void (*finalizer) (void *header, int for_disksave);
153
188 /* This can be NULL, meaning compare objects with EQ(). */ 154 /* This can be NULL, meaning compare objects with EQ(). */
189 int (*equal) (Lisp_Object obj1, Lisp_Object obj2, int depth); 155 int (*equal) (Lisp_Object obj1, Lisp_Object obj2, int depth);
190 /* This can be NULL, meaning use the Lisp_Object itself as the hash; 156
191 but *only* if the `equal' function is EQ (if two objects are 157 /* `hash' generates hash values for use with hash tables that have
192 `equal', they *must* hash to the same value or the hashing won't 158 `equal' as their test function. This can be NULL, meaning use
193 work). */ 159 the Lisp_Object itself as the hash. But, you must still satisfy
160 the constraint that if two objects are `equal', then they *must*
161 hash to the same value in order for hash tables to work properly.
162 This means that `hash' can be NULL only if the `equal' method is
163 also NULL. */
194 unsigned long (*hash) (Lisp_Object, int); 164 unsigned long (*hash) (Lisp_Object, int);
165
166 /* External data layout description */
167 const struct lrecord_description *description;
168
169 /* These functions allow any object type to have builtin property
170 lists that can be manipulated from the lisp level with
171 `get', `put', `remprop', and `object-plist'. */
195 Lisp_Object (*getprop) (Lisp_Object obj, Lisp_Object prop); 172 Lisp_Object (*getprop) (Lisp_Object obj, Lisp_Object prop);
196 int (*putprop) (Lisp_Object obj, Lisp_Object prop, Lisp_Object val); 173 int (*putprop) (Lisp_Object obj, Lisp_Object prop, Lisp_Object val);
197 int (*remprop) (Lisp_Object obj, Lisp_Object prop); 174 int (*remprop) (Lisp_Object obj, Lisp_Object prop);
198 Lisp_Object (*plist) (Lisp_Object obj); 175 Lisp_Object (*plist) (Lisp_Object obj);
199 176
200 /* Only one of these is non-0. If both are 0, it means that this type 177 /* Only one of `static_size' and `size_in_bytes_method' is non-0.
201 is not instantiable by alloc_lcrecord(). */ 178 If both are 0, this type is not instantiable by alloc_lcrecord(). */
202 size_t static_size; 179 size_t static_size;
203 size_t (*size_in_bytes_method) (CONST void *header); 180 size_t (*size_in_bytes_method) (const void *header);
181
204 /* A unique subtag-code (dynamically) assigned to this datatype. */ 182 /* A unique subtag-code (dynamically) assigned to this datatype. */
205 /* (This is a pointer so the rest of this structure can be read-only.) */ 183 /* (This is a pointer so the rest of this structure can be read-only.) */
206 int *lrecord_type_index; 184 int *lrecord_type_index;
185
207 /* A "basic" lrecord is any lrecord that's not an lcrecord, i.e. 186 /* A "basic" lrecord is any lrecord that's not an lcrecord, i.e.
208 one that does not have an lcrecord_header at the front and which 187 one that does not have an lcrecord_header at the front and which
209 is (usually) allocated in frob blocks. We only use this flag for 188 is (usually) allocated in frob blocks. We only use this flag for
210 some consistency checking, and that only when error-checking is 189 some consistency checking, and that only when error-checking is
211 enabled. */ 190 enabled. */
212 int basic_p; 191 unsigned int basic_p :1;
213 }; 192 };
214 193
215 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION 194 extern const struct lrecord_implementation *lrecord_implementations_table[];
216 extern CONST struct lrecord_implementation *lrecord_implementations_table[]; 195
217 196 #define XRECORD_LHEADER_IMPLEMENTATION(obj) \
218 # define XRECORD_LHEADER_IMPLEMENTATION(obj) \
219 (lrecord_implementations_table[XRECORD_LHEADER (obj)->type]) 197 (lrecord_implementations_table[XRECORD_LHEADER (obj)->type])
220 # define LHEADER_IMPLEMENTATION(lh) (lrecord_implementations_table[(lh)->type]) 198 #define LHEADER_IMPLEMENTATION(lh) (lrecord_implementations_table[(lh)->type])
221 #else
222 # define XRECORD_LHEADER_IMPLEMENTATION(obj) \
223 (XRECORD_LHEADER (obj)->implementation)
224 # define LHEADER_IMPLEMENTATION(lh) ((lh)->implementation)
225 #endif
226 199
227 extern int gc_in_progress; 200 extern int gc_in_progress;
228 201
229 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION 202 #define MARKED_RECORD_P(obj) (gc_in_progress && XRECORD_LHEADER (obj)->mark)
230 # define MARKED_RECORD_P(obj) (gc_in_progress && XRECORD_LHEADER (obj)->mark) 203 #define MARKED_RECORD_HEADER_P(lheader) ((lheader)->mark)
231 #else 204 #define MARK_RECORD_HEADER(lheader) ((void) ((lheader)->mark = 1))
232 # define MARKED_RECORD_P(obj) (gc_in_progress && \ 205 #define UNMARK_RECORD_HEADER(lheader) ((void) ((lheader)->mark = 0))
233 XRECORD_LHEADER (obj)->implementation->finalizer == \
234 this_marks_a_marked_record)
235 #endif
236
237 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
238
239 # define MARKED_RECORD_HEADER_P(lheader) ((lheader)->mark)
240 # define MARK_RECORD_HEADER(lheader) ((void) ((lheader)->mark = 1))
241 # define UNMARK_RECORD_HEADER(lheader) ((void) ((lheader)->mark = 0))
242
243 #else /* ! USE_INDEXED_LRECORD_IMPLEMENTATION */
244
245 # define MARKED_RECORD_HEADER_P(lheader) \
246 ((lheader)->implementation->finalizer == this_marks_a_marked_record)
247 # define MARK_RECORD_HEADER(lheader) ((void) (((lheader)->implementation)++))
248 # define UNMARK_RECORD_HEADER(lheader) ((void) (((lheader)->implementation)--))
249
250 #endif /* ! USE_INDEXED_LRECORD_IMPLEMENTATION */
251 206
252 #define UNMARKABLE_RECORD_HEADER_P(lheader) \ 207 #define UNMARKABLE_RECORD_HEADER_P(lheader) \
253 (LHEADER_IMPLEMENTATION (lheader)->marker == this_one_is_unmarkable) 208 (LHEADER_IMPLEMENTATION (lheader)->marker == this_one_is_unmarkable)
209
210 #define C_READONLY_RECORD_HEADER_P(lheader) ((lheader)->c_readonly)
211 #define LISP_READONLY_RECORD_HEADER_P(lheader) ((lheader)->lisp_readonly)
212 #define SET_C_READONLY_RECORD_HEADER(lheader) \
213 ((void) ((lheader)->c_readonly = (lheader)->lisp_readonly = 1))
214 #define SET_LISP_READONLY_RECORD_HEADER(lheader) \
215 ((void) ((lheader)->lisp_readonly = 1))
216
217 /* External description stuff
218
219 A lrecord external description is an array of values. The first
220 value of each line is a type, the second the offset in the lrecord
221 structure. Following values are parameters, their presence, type
222 and number is type-dependant.
223
224 The description ends with a "XD_END" or "XD_SPECIFIER_END" record.
225
226 Some example descriptions :
227
228 static const struct lrecord_description cons_description[] = {
229 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car) },
230 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr) },
231 { XD_END }
232 };
233
234 Which means "two lisp objects starting at the 'car' and 'cdr' elements"
235
236 static const struct lrecord_description string_description[] = {
237 { XD_BYTECOUNT, offsetof (Lisp_String, size) },
238 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data), XD_INDIRECT(0, 1) },
239 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) },
240 { XD_END }
241 };
242 "A pointer to string data at 'data', the size of the pointed array being the value
243 of the size variable plus 1, and one lisp object at 'plist'"
244
245 The existing types :
246 XD_LISP_OBJECT
247 A Lisp object. This is also the type to use for pointers to other lrecords.
248
249 XD_LISP_OBJECT_ARRAY
250 An array of Lisp objects or pointers to lrecords.
251 The third element is the count.
252
253 XD_LO_RESET_NIL
254 Lisp objects which will be reset to Qnil when dumping. Useful for cleaning
255 up caches.
256
257 XD_LO_LINK
258 Link in a linked list of objects of the same type.
259
260 XD_OPAQUE_PTR
261 Pointer to undumpable data. Must be NULL when dumping.
262
263 XD_STRUCT_PTR
264 Pointer to described struct. Parameters are number of structures and
265 struct_description.
266
267 XD_OPAQUE_DATA_PTR
268 Pointer to dumpable opaque data. Parameter is the size of the data.
269 Pointed data must be relocatable without changes.
270
271 XD_C_STRING
272 Pointer to a C string.
273
274 XD_DOC_STRING
275 Pointer to a doc string (C string if positive, opaque value if negative)
276
277 XD_INT_RESET
278 An integer which will be reset to a given value in the dump file.
279
280
281 XD_SIZE_T
282 size_t value. Used for counts.
283
284 XD_INT
285 int value. Used for counts.
286
287 XD_LONG
288 long value. Used for counts.
289
290 XD_BYTECOUNT
291 bytecount value. Used for counts.
292
293 XD_END
294 Special type indicating the end of the array.
295
296 XD_SPECIFIER_END
297 Special type indicating the end of the array for a specifier. Extra
298 description is going to be fetched from the specifier methods.
299
300
301 Special macros:
302 XD_INDIRECT(line, delta)
303 Usable where a "count" or "size" is requested. Gives the value of
304 the element which is at line number 'line' in the description (count
305 starts at zero) and adds delta to it.
306 */
307
308 enum lrecord_description_type {
309 XD_LISP_OBJECT_ARRAY,
310 XD_LISP_OBJECT,
311 XD_LO_RESET_NIL,
312 XD_LO_LINK,
313 XD_OPAQUE_PTR,
314 XD_STRUCT_PTR,
315 XD_OPAQUE_DATA_PTR,
316 XD_C_STRING,
317 XD_DOC_STRING,
318 XD_INT_RESET,
319 XD_SIZE_T,
320 XD_INT,
321 XD_LONG,
322 XD_BYTECOUNT,
323 XD_END,
324 XD_SPECIFIER_END
325 };
326
327 struct lrecord_description {
328 enum lrecord_description_type type;
329 int offset;
330 EMACS_INT data1;
331 const struct struct_description *data2;
332 };
333
334 struct struct_description {
335 size_t size;
336 const struct lrecord_description *description;
337 };
338
339 #define XD_INDIRECT(val, delta) (-1-((val)|(delta<<8)))
340
341 #define XD_IS_INDIRECT(code) (code<0)
342 #define XD_INDIRECT_VAL(code) ((-1-code) & 255)
343 #define XD_INDIRECT_DELTA(code) (((-1-code)>>8) & 255)
344
345 #define XD_DYNARR_DESC(base_type, sub_desc) \
346 { XD_STRUCT_PTR, offsetof (base_type, base), XD_INDIRECT(1, 0), sub_desc }, \
347 { XD_INT, offsetof (base_type, cur) }, \
348 { XD_INT_RESET, offsetof (base_type, max), XD_INDIRECT(1, 0) }
254 349
255 /* Declaring the following structures as const puts them in the 350 /* Declaring the following structures as const puts them in the
256 text (read-only) segment, which makes debugging inconvenient 351 text (read-only) segment, which makes debugging inconvenient
257 because this segment is not mapped when processing a core- 352 because this segment is not mapped when processing a core-
258 dump file */ 353 dump file */
259 354
260 #ifdef DEBUG_XEMACS 355 #ifdef DEBUG_XEMACS
261 #define CONST_IF_NOT_DEBUG 356 #define CONST_IF_NOT_DEBUG
262 #else 357 #else
263 #define CONST_IF_NOT_DEBUG CONST 358 #define CONST_IF_NOT_DEBUG const
264 #endif 359 #endif
265 360
266 /* DEFINE_LRECORD_IMPLEMENTATION is for objects with constant size. 361 /* DEFINE_LRECORD_IMPLEMENTATION is for objects with constant size.
267 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION is for objects whose size varies. 362 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION is for objects whose size varies.
268 */ 363 */
271 # define DECLARE_ERROR_CHECK_TYPECHECK(c_name, structtype) 366 # define DECLARE_ERROR_CHECK_TYPECHECK(c_name, structtype)
272 #else 367 #else
273 # define DECLARE_ERROR_CHECK_TYPECHECK(c_name, structtype) 368 # define DECLARE_ERROR_CHECK_TYPECHECK(c_name, structtype)
274 #endif 369 #endif
275 370
276 #define DEFINE_BASIC_LRECORD_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,structtype) \ 371 #define DEFINE_BASIC_LRECORD_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,desc,structtype) \
277 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS(name,c_name,marker,printer,nuker,equal,hash,0,0,0,0,structtype) 372 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS(name,c_name,marker,printer,nuker,equal,hash,desc,0,0,0,0,structtype)
278 373
279 #define DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS(name,c_name,marker,printer,nuker,equal,hash,getprop,putprop,remprop,props,structtype) \ 374 #define DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS(name,c_name,marker,printer,nuker,equal,hash,desc,getprop,putprop,remprop,plist,structtype) \
280 MAKE_LRECORD_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,getprop,putprop,remprop,props,sizeof(structtype),0,1,structtype) 375 MAKE_LRECORD_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,desc,getprop,putprop,remprop,plist,sizeof(structtype),0,1,structtype)
281 376
282 #define DEFINE_LRECORD_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,structtype) \ 377 #define DEFINE_LRECORD_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,desc,structtype) \
283 DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS(name,c_name,marker,printer,nuker,equal,hash,0,0,0,0,structtype) 378 DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS(name,c_name,marker,printer,nuker,equal,hash,desc,0,0,0,0,structtype)
284 379
285 #define DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS(name,c_name,marker,printer,nuker,equal,hash,getprop,putprop,remprop,props,structtype) \ 380 #define DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS(name,c_name,marker,printer,nuker,equal,hash,desc,getprop,putprop,remprop,plist,structtype) \
286 MAKE_LRECORD_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,getprop,putprop,remprop,props,sizeof (structtype),0,0,structtype) 381 MAKE_LRECORD_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,desc,getprop,putprop,remprop,plist,sizeof (structtype),0,0,structtype)
287 382
288 #define DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,sizer,structtype) \ 383 #define DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,desc,sizer,structtype) \
289 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION_WITH_PROPS(name,c_name,marker,printer,nuker,equal,hash,0,0,0,0,sizer,structtype) 384 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION_WITH_PROPS(name,c_name,marker,printer,nuker,equal,hash,desc,0,0,0,0,sizer,structtype)
290 385
291 #define DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION_WITH_PROPS(name,c_name,marker,printer,nuker,equal,hash,getprop,putprop,remprop,props,sizer,structtype) \ 386 #define DEFINE_BASIC_LRECORD_SEQUENCE_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,desc,sizer,structtype) \
292 MAKE_LRECORD_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,getprop,putprop,remprop,props,0,sizer,0,structtype) \ 387 MAKE_LRECORD_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,desc,0,0,0,0,0,sizer,1,structtype)
293 388
294 #define MAKE_LRECORD_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,getprop,putprop,remprop,props,size,sizer,basic_p,structtype) \ 389 #define DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION_WITH_PROPS(name,c_name,marker,printer,nuker,equal,hash,desc,getprop,putprop,remprop,plist,sizer,structtype) \
390 MAKE_LRECORD_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,desc,getprop,putprop,remprop,plist,0,sizer,0,structtype) \
391
392 #define MAKE_LRECORD_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,desc,getprop,putprop,remprop,plist,size,sizer,basic_p,structtype) \
295 DECLARE_ERROR_CHECK_TYPECHECK(c_name, structtype) \ 393 DECLARE_ERROR_CHECK_TYPECHECK(c_name, structtype) \
296 static int lrecord_##c_name##_lrecord_type_index; \ 394 static int lrecord_##c_name##_lrecord_type_index; \
297 CONST_IF_NOT_DEBUG struct lrecord_implementation lrecord_##c_name[2] = \ 395 CONST_IF_NOT_DEBUG struct lrecord_implementation lrecord_##c_name = \
298 { { name, marker, printer, nuker, equal, hash, \ 396 { name, marker, printer, nuker, equal, hash, desc, \
299 getprop, putprop, remprop, props, size, sizer, \ 397 getprop, putprop, remprop, plist, size, sizer, \
300 &(lrecord_##c_name##_lrecord_type_index), basic_p }, \ 398 &(lrecord_##c_name##_lrecord_type_index), basic_p } \
301 { 0, 0, 0, this_marks_a_marked_record, 0, 0, 0, 0, 0, 0, 0, 0, 0, basic_p } } 399
302 400 #define LRECORDP(a) (XTYPE (a) == Lisp_Type_Record)
303 #define LRECORDP(a) (XTYPE ((a)) == Lisp_Type_Record)
304 #define XRECORD_LHEADER(a) ((struct lrecord_header *) XPNTR (a)) 401 #define XRECORD_LHEADER(a) ((struct lrecord_header *) XPNTR (a))
305 402
306 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION 403 #define RECORD_TYPEP(x, ty) \
307 # define RECORD_TYPEP(x, ty) \
308 (LRECORDP (x) && \ 404 (LRECORDP (x) && \
309 lrecord_implementations_table[XRECORD_LHEADER (x)->type] == (ty)) 405 lrecord_implementations_table[XRECORD_LHEADER (x)->type] == (ty))
310 #else
311 # define RECORD_TYPEP(x, ty) \
312 (LRECORDP (x) && XRECORD_LHEADER (x)->implementation == (ty))
313 #endif
314 406
315 /* NOTE: the DECLARE_LRECORD() must come before the associated 407 /* NOTE: the DECLARE_LRECORD() must come before the associated
316 DEFINE_LRECORD_*() or you will get compile errors. 408 DEFINE_LRECORD_*() or you will get compile errors.
317 409
318 Furthermore, you always need to put the DECLARE_LRECORD() in a header 410 Furthermore, you always need to put the DECLARE_LRECORD() in a header
323 415
324 #ifdef ERROR_CHECK_TYPECHECK 416 #ifdef ERROR_CHECK_TYPECHECK
325 417
326 # define DECLARE_LRECORD(c_name, structtype) \ 418 # define DECLARE_LRECORD(c_name, structtype) \
327 extern CONST_IF_NOT_DEBUG struct lrecord_implementation \ 419 extern CONST_IF_NOT_DEBUG struct lrecord_implementation \
328 lrecord_##c_name[]; \ 420 lrecord_##c_name; \
329 INLINE structtype *error_check_##c_name (Lisp_Object obj); \ 421 INLINE structtype *error_check_##c_name (Lisp_Object obj); \
330 INLINE structtype * \ 422 INLINE structtype * \
331 error_check_##c_name (Lisp_Object obj) \ 423 error_check_##c_name (Lisp_Object obj) \
332 { \ 424 { \
333 XUNMARK (obj); \ 425 assert (RECORD_TYPEP (obj, &lrecord_##c_name)); \
334 assert (RECORD_TYPEP (obj, lrecord_##c_name) || \
335 MARKED_RECORD_P (obj)); \
336 return (structtype *) XPNTR (obj); \ 426 return (structtype *) XPNTR (obj); \
337 } \ 427 } \
338 extern Lisp_Object Q##c_name##p 428 extern Lisp_Object Q##c_name##p
339 429
340 # define DECLARE_NONRECORD(c_name, type_enum, structtype) \ 430 # define DECLARE_NONRECORD(c_name, type_enum, structtype) \
341 INLINE structtype *error_check_##c_name (Lisp_Object obj); \ 431 INLINE structtype *error_check_##c_name (Lisp_Object obj); \
342 INLINE structtype * \ 432 INLINE structtype * \
343 error_check_##c_name (Lisp_Object obj) \ 433 error_check_##c_name (Lisp_Object obj) \
344 { \ 434 { \
345 XUNMARK (obj); \ 435 assert (XTYPE (obj) == type_enum); \
346 assert (XGCTYPE (obj) == type_enum); \
347 return (structtype *) XPNTR (obj); \ 436 return (structtype *) XPNTR (obj); \
348 } \ 437 } \
349 extern Lisp_Object Q##c_name##p 438 extern Lisp_Object Q##c_name##p
350 439
351 # define XRECORD(x, c_name, structtype) error_check_##c_name (x) 440 # define XRECORD(x, c_name, structtype) error_check_##c_name (x)
352 # define XNONRECORD(x, c_name, type_enum, structtype) error_check_##c_name (x) 441 # define XNONRECORD(x, c_name, type_enum, structtype) error_check_##c_name (x)
353 442
354 # define XSETRECORD(var, p, c_name) do \ 443 # define XSETRECORD(var, p, c_name) do \
355 { \ 444 { \
356 XSETOBJ (var, Lisp_Type_Record, p); \ 445 XSETOBJ (var, Lisp_Type_Record, p); \
357 assert (RECORD_TYPEP (var, lrecord_##c_name) || \ 446 assert (RECORD_TYPEP (var, &lrecord_##c_name)); \
358 MARKED_RECORD_P (var)); \
359 } while (0) 447 } while (0)
360 448
361 #else /* not ERROR_CHECK_TYPECHECK */ 449 #else /* not ERROR_CHECK_TYPECHECK */
362 450
363 # define DECLARE_LRECORD(c_name, structtype) \ 451 # define DECLARE_LRECORD(c_name, structtype) \
364 extern Lisp_Object Q##c_name##p; \ 452 extern Lisp_Object Q##c_name##p; \
365 extern CONST_IF_NOT_DEBUG struct lrecord_implementation \ 453 extern CONST_IF_NOT_DEBUG struct lrecord_implementation \
366 lrecord_##c_name[] 454 lrecord_##c_name
367 # define DECLARE_NONRECORD(c_name, type_enum, structtype) \ 455 # define DECLARE_NONRECORD(c_name, type_enum, structtype) \
368 extern Lisp_Object Q##c_name##p 456 extern Lisp_Object Q##c_name##p
369 # define XRECORD(x, c_name, structtype) ((structtype *) XPNTR (x)) 457 # define XRECORD(x, c_name, structtype) ((structtype *) XPNTR (x))
370 # define XNONRECORD(x, c_name, type_enum, structtype) \ 458 # define XNONRECORD(x, c_name, type_enum, structtype) \
371 ((structtype *) XPNTR (x)) 459 ((structtype *) XPNTR (x))
372 # define XSETRECORD(var, p, c_name) XSETOBJ (var, Lisp_Type_Record, p) 460 # define XSETRECORD(var, p, c_name) XSETOBJ (var, Lisp_Type_Record, p)
373 461
374 #endif /* not ERROR_CHECK_TYPECHECK */ 462 #endif /* not ERROR_CHECK_TYPECHECK */
375 463
376 #define RECORDP(x, c_name) RECORD_TYPEP (x, lrecord_##c_name) 464 #define RECORDP(x, c_name) RECORD_TYPEP (x, &lrecord_##c_name)
377 #define GC_RECORDP(x, c_name) gc_record_type_p (x, lrecord_##c_name)
378 465
379 /* Note: we now have two different kinds of type-checking macros. 466 /* Note: we now have two different kinds of type-checking macros.
380 The "old" kind has now been renamed CONCHECK_foo. The reason for 467 The "old" kind has now been renamed CONCHECK_foo. The reason for
381 this is that the CONCHECK_foo macros signal a continuable error, 468 this is that the CONCHECK_foo macros signal a continuable error,
382 allowing the user (through debug-on-error) to substitute a different 469 allowing the user (through debug-on-error) to substitute a different
398 485
399 FSF Emacs does not have this problem because RMS took the cheesy 486 FSF Emacs does not have this problem because RMS took the cheesy
400 way out and disabled returning from a signal entirely. */ 487 way out and disabled returning from a signal entirely. */
401 488
402 #define CONCHECK_RECORD(x, c_name) do { \ 489 #define CONCHECK_RECORD(x, c_name) do { \
403 if (!RECORD_TYPEP (x, lrecord_##c_name)) \ 490 if (!RECORD_TYPEP (x, &lrecord_##c_name)) \
404 x = wrong_type_argument (Q##c_name##p, x); \ 491 x = wrong_type_argument (Q##c_name##p, x); \
405 } while (0) 492 } while (0)
406 #define CONCHECK_NONRECORD(x, lisp_enum, predicate) do {\ 493 #define CONCHECK_NONRECORD(x, lisp_enum, predicate) do {\
407 if (XTYPE (x) != lisp_enum) \ 494 if (XTYPE (x) != lisp_enum) \
408 x = wrong_type_argument (predicate, x); \ 495 x = wrong_type_argument (predicate, x); \
409 } while (0) 496 } while (0)
410 #define CHECK_RECORD(x, c_name) do { \ 497 #define CHECK_RECORD(x, c_name) do { \
411 if (!RECORD_TYPEP (x, lrecord_##c_name)) \ 498 if (!RECORD_TYPEP (x, &lrecord_##c_name)) \
412 dead_wrong_type_argument (Q##c_name##p, x); \ 499 dead_wrong_type_argument (Q##c_name##p, x); \
413 } while (0) 500 } while (0)
414 #define CHECK_NONRECORD(x, lisp_enum, predicate) do { \ 501 #define CHECK_NONRECORD(x, lisp_enum, predicate) do { \
415 if (XTYPE (x) != lisp_enum) \ 502 if (XTYPE (x) != lisp_enum) \
416 dead_wrong_type_argument (predicate, x); \ 503 dead_wrong_type_argument (predicate, x); \
417 } while (0) 504 } while (0)
418 505
419 void *alloc_lcrecord (size_t size, CONST struct lrecord_implementation *); 506 void *alloc_lcrecord (size_t size, const struct lrecord_implementation *);
420 507
421 #define alloc_lcrecord_type(type, lrecord_implementation) \ 508 #define alloc_lcrecord_type(type, lrecord_implementation) \
422 ((type *) alloc_lcrecord (sizeof (type), lrecord_implementation)) 509 ((type *) alloc_lcrecord (sizeof (type), lrecord_implementation))
423 510
424 int gc_record_type_p (Lisp_Object frob,
425 CONST struct lrecord_implementation *type);
426
427 /* Copy the data from one lcrecord structure into another, but don't 511 /* Copy the data from one lcrecord structure into another, but don't
428 overwrite the header information. */ 512 overwrite the header information. */
429 513
430 #define copy_lcrecord(dst, src) \ 514 #define copy_lcrecord(dst, src) \
431 memcpy ((char *) dst + sizeof (struct lcrecord_header), \ 515 memcpy ((char *) (dst) + sizeof (struct lcrecord_header), \
432 (char *) src + sizeof (struct lcrecord_header), \ 516 (char *) (src) + sizeof (struct lcrecord_header), \
433 sizeof (*dst) - sizeof (struct lcrecord_header)) 517 sizeof (*(dst)) - sizeof (struct lcrecord_header))
434 518
435 #define zero_lcrecord(lcr) \ 519 #define zero_lcrecord(lcr) \
436 memset ((char *) lcr + sizeof (struct lcrecord_header), 0, \ 520 memset ((char *) (lcr) + sizeof (struct lcrecord_header), 0, \
437 sizeof (*lcr) - sizeof (struct lcrecord_header)) 521 sizeof (*(lcr)) - sizeof (struct lcrecord_header))
438 522
439 #endif /* _XEMACS_LRECORD_H_ */ 523 #endif /* INCLUDED_lrecord_h_ */