Mercurial > hg > xemacs-beta

comparison src/opaque.c @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 8eaf7971accc
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 /* Opaque Lisp objects.
2 Copyright (C) 1993, 1994, 1995 Sun Microsystems, Inc.
3 Copyright (C) 1995, 1996 Ben Wing.
4
5 This file is part of XEmacs.
6
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
10 later version.
11
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
21
22 /* Synched up with: Not in FSF. */
23
24 /* Written by Ben Wing, October 1993. */
25
26 /* "Opaque" is used internally to hold keep track of allocated memory
27 so it gets GC'd properly, and to store arbitrary data in places
28 where a Lisp_Object is required and which may get GC'd. (e.g. as
29 the argument to record_unwind_protect()). Once created in C,
30 opaque objects cannot be resized.
31
32 OPAQUE OBJECTS SHOULD NEVER ESCAPE TO THE LISP LEVEL. Some code
33 depends on this. As such, opaque objects are a generalization
34 of the Qunbound marker.
35
36 "Opaque lists" are used to keep track of lots of opaque objects
37 of a particular size so that they can be efficiently "freed" and
38 re-used again without actually entering the Lisp allocation system
39 (and consequently doing a malloc()).
40 */
41
42 #include <config.h>
43 #include "lisp.h"
44 #include "opaque.h"
45
46 Lisp_Object Qopaquep;
47
48 static int in_opaque_list_marking;
49
50 /* Holds freed opaque objects created with make_opaque_ptr().
51 We do this quite often so it's a noticeable win if we don't
52 create GC junk. */
53 Lisp_Object Vopaque_ptr_free_list;
54
55 static Lisp_Object mark_opaque (Lisp_Object, void (*) (Lisp_Object));
56 static unsigned int sizeof_opaque (CONST void *header);
57 static void print_opaque (Lisp_Object obj, Lisp_Object printcharfun,
58 int escapeflag);
59 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque,
60 mark_opaque, print_opaque, 0, 0, 0,
61 sizeof_opaque, struct Lisp_Opaque);
62
63 static Lisp_Object
64 mark_opaque (Lisp_Object obj, void (*markobj) (Lisp_Object))
65 {
66 #ifdef ERROR_CHECK_GC
67 if (!in_opaque_list_marking)
68 /* size is non-int for objects on an opaque free list. We sure
69 as hell better not be marking any of these objects unless
70 we're marking an opaque list. */
71 assert (INTP (XOPAQUE (obj)->size_or_chain));
72 else
73 /* marking an opaque on the free list doesn't do any recursive
74 markings, so we better not have non-freed opaques on a free
75 list. */
76 assert (!INTP (XOPAQUE (obj)->size_or_chain));
77 #endif
78 if (INTP (XOPAQUE (obj)->size_or_chain) && XOPAQUE_MARKFUN (obj))
79 return (XOPAQUE_MARKFUN (obj)) (obj, markobj);
80 else
81 return XOPAQUE (obj)->size_or_chain;
82 }
83
84 /* Should never, ever be called. (except by an external debugger) */
85 static void
86 print_opaque (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
87 {
88 char buf[200];
89 if (INTP (XOPAQUE (obj)->size_or_chain))
90 sprintf (buf, "#<INTERNAL EMACS BUG (opaque, size=%d) 0x%x>",
91 (EMACS_INT) XOPAQUE_SIZE (obj),
92 (EMACS_INT) XPNTR (obj));
93 else
94 sprintf (buf, "#<INTERNAL EMACS BUG (opaque, freed) 0x%x>",
95 (EMACS_INT) XPNTR (obj));
96 write_c_string (buf, printcharfun);
97 }
98
99 static unsigned int
100 sizeof_opaque (CONST void *header)
101 {
102 CONST struct Lisp_Opaque *p = (CONST struct Lisp_Opaque *) header;
103 if (!INTP (p->size_or_chain))
104 return sizeof (*p);
105 return sizeof (*p) + XINT (p->size_or_chain) - sizeof (int);
106 }
107
108 Lisp_Object
109 make_opaque (int size, CONST void *data)
110 {
111 struct Lisp_Opaque *p = alloc_lcrecord (sizeof (*p) + size - sizeof (int),
112 lrecord_opaque);
113 Lisp_Object val;
114
115 p->markfun = 0;
116 p->size_or_chain = make_int (size);
117 if (data)
118 memcpy (p->data, data, size);
119 else
120 memset (p->data, 0, size);
121 XSETOPAQUE (val, p);
122 return val;
123 }
124
125 static Lisp_Object mark_opaque_list (Lisp_Object, void (*) (Lisp_Object));
126 DEFINE_LRECORD_IMPLEMENTATION ("opaque-list", opaque_list,
127 mark_opaque_list, internal_object_printer,
128 0, 0, 0, struct Lisp_Opaque_List);
129
130 static Lisp_Object
131 mark_opaque_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
132 {
133 in_opaque_list_marking++;
134 (markobj) (XOPAQUE_LIST (obj)->free);
135 in_opaque_list_marking--;
136 return Qnil;
137 }
138
139 Lisp_Object
140 make_opaque_list (int size,
141 Lisp_Object (*markfun) (Lisp_Object obj,
142 void (*markobj) (Lisp_Object)))
143 {
144 struct Lisp_Opaque_List *p = alloc_lcrecord (sizeof (*p),
145 lrecord_opaque_list);
146 Lisp_Object val = Qnil;
147
148 p->markfun = markfun;
149 p->size = size;
150 p->free = Qnil;
151 XSETOPAQUE_LIST (val, p);
152 return val;
153 }
154
155 Lisp_Object
156 allocate_managed_opaque (Lisp_Object opaque_list, CONST void *data)
157 {
158 struct Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list);
159 Lisp_Object val;
160
161 if (!NILP (li->free))
162 {
163 val = li->free;
164 li->free = XOPAQUE (val)->size_or_chain;
165 #ifdef ERROR_CHECK_GC
166 assert (NILP (li->free) || OPAQUEP (li->free));
167 #endif
168 XOPAQUE (val)->size_or_chain = make_int (li->size);
169 if (data)
170 memcpy (XOPAQUE (val)->data, data, li->size);
171 else
172 memset (XOPAQUE (val)->data, 0, li->size);
173 }
174 else
175 val = make_opaque (li->size, data);
176 XOPAQUE (val)->markfun = li->markfun;
177 return val;
178 }
179
180 void
181 free_managed_opaque (Lisp_Object opaque_list, Lisp_Object opaque)
182 {
183 struct Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list);
184
185 #ifdef ERROR_CHECK_GC
186 assert (INTP (XOPAQUE (opaque)->size_or_chain));
187 #endif
188 XOPAQUE (opaque)->size_or_chain = li->free;
189 li->free = opaque;
190 }
191
192 /* stuff to handle opaque pointers */
193
194 Lisp_Object
195 make_opaque_ptr (CONST void *val)
196 {
197 return allocate_managed_opaque (Vopaque_ptr_free_list,
198 (CONST void *) &val);
199 }
200
201 /* Be wery wery careful with this. Same admonitions as with
202 free_cons() apply. */
203
204 void
205 free_opaque_ptr (Lisp_Object ptr)
206 {
207 free_managed_opaque (Vopaque_ptr_free_list, ptr);
208 }
209
210 Lisp_Object
211 make_opaque_long (long val)
212 {
213 return make_opaque (sizeof (val), (void *) &val);
214 }
215
216 void
217 init_opaque_once_early (void)
218 {
219 Vopaque_ptr_free_list = make_opaque_list (sizeof (void *), 0);
220 staticpro (&Vopaque_ptr_free_list);
221 }