1 /* $Id: object.c,v 1.14 2001/08/10 16:27:04 sandro Exp $ */
2
3 /*
4 * Copyright (c) 1997-2001 Sandro Sigala. All rights reserved.
5 *
6 * Redistribution and use in source and binary forms, with or without
7 * modification, are permitted provided that the following conditions
8 * are met:
9 * 1. Redistributions of source code must retain the above copyright
10 * notice, this list of conditions and the following disclaimer.
11 * 2. Redistributions in binary form must reproduce the above copyright
12 * notice, this list of conditions and the following disclaimer in the
13 * documentation and/or other materials provided with the distribution.
14 *
15 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
16 * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
17 * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
18 * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
19 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
20 * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
21 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
23 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
24 * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
25 */
26
27 #include "config.h"
28
29 #include <assert.h>
30 #include <limits.h>
31 #include <stdio.h>
32 #include <stdlib.h>
33 #include <string.h>
34 #include <err.h>
35
36 #include "slisp.h"
37 #include "extern.h"
38
39 /*--------------------------------------------------------------------------
40 * Object allocator functions.
41 *--------------------------------------------------------------------------*/
42
43 objectp nil, t;
44
45 static objectp free_objs_list = NULL;
46 static objectp used_objs_list = NULL;
47
48 int free_objs = 0;
49 int used_objs = 0;
50
new_object(int type)51 objectp new_object(int type)
52 {
53 objectp p;
54
55 if (free_objs_list == NULL) {
56 p = (objectp)xmalloc(sizeof(struct object));
57 #ifdef DEBUG
58 warnx(":: allocating cons %p", p);
59 #endif
60 } else {
61 p = free_objs_list;
62 free_objs_list = free_objs_list->next;
63 --free_objs;
64 #ifdef DEBUG
65 warnx(":: recycling cons %p", p);
66 #endif
67 }
68
69 p->next = used_objs_list;
70 used_objs_list = p;
71
72 p->type = type;
73 if (type == OBJ_CONS) {
74 p->value.c.car = nil;
75 p->value.c.cdr = nil;
76 }
77 p->gc = 0;
78
79 ++used_objs;
80
81 return p;
82 }
83
search_object_identifier(char * s)84 objectp search_object_identifier(char *s)
85 {
86 objectp p;
87
88 for (p = used_objs_list; p != NULL; p = p->next)
89 if (p->type == OBJ_IDENTIFIER && !strcmp(p->value.id, s))
90 return p;
91
92 return NULL;
93 }
94
search_object_string(char * s)95 objectp search_object_string(char *s)
96 {
97 objectp p;
98
99 for (p = used_objs_list; p != NULL; p = p->next)
100 if (p->type == OBJ_STRING && !strcmp(p->value.s, s))
101 return p;
102
103 return NULL;
104 }
105
search_object_integer(int in)106 objectp search_object_integer(int in)
107 {
108 objectp p;
109
110 for (p = used_objs_list; p != NULL; p = p->next)
111 if (p->type == OBJ_INTEGER && p->value.i == in)
112 return p;
113
114 return NULL;
115 }
116
init_objects(void)117 void init_objects(void)
118 {
119 nil = new_object(OBJ_NIL);
120 t = new_object(OBJ_T);
121 }
122
123 /*--------------------------------------------------------------------------
124 * Object set functions.
125 *--------------------------------------------------------------------------*/
126
127 typedef struct object_pair *object_pairp;
128 struct object_pair {
129 objectp name;
130 objectp value;
131 object_pairp next;
132 };
133
134 static object_pairp setobjs_list = NULL;
135
set_object(objectp name,objectp value)136 void set_object(objectp name, objectp value)
137 {
138 object_pairp p;
139
140 if (name->value.id == NULL)
141 return;
142
143 for (p = setobjs_list; p != NULL; p = p->next)
144 if (p->name->value.id != NULL &&
145 !strcmp(name->value.id, p->name->value.id)) {
146 p->value = value;
147 return;
148 }
149
150 p = (object_pairp)xmalloc(sizeof(struct object_pair));
151 p->next = setobjs_list;
152 setobjs_list = p;
153 p->name = name;
154 p->value = value;
155 }
156
get_object(objectp name)157 objectp get_object(objectp name)
158 {
159 object_pairp p;
160
161 for (p = setobjs_list; p != NULL; p = p->next)
162 if (p->name->value.id != NULL &&
163 !strcmp(name->value.id, p->name->value.id))
164 return p->value;
165
166 return nil;
167 }
168
dump_objects(char * fname)169 void dump_objects(char *fname)
170 {
171 object_pairp p;
172 FILE *fout;
173
174 if ((fout = fopen(fname, "w")) == NULL)
175 err(1, "%s", fname);
176
177 for (p = setobjs_list; p != NULL; p = p->next) {
178 fprintf(fout, "(setq %s '", p->name->value.id);
179 princ_object(fout, p->value);
180 fprintf(fout, ")\n");
181 }
182
183 fclose(fout);
184 }
185
186 #ifdef DEBUG
obj_type_str(objectp p)187 static char *obj_type_str(objectp p)
188 {
189 switch (p->type) {
190 case OBJ_NIL: return "nil";
191 case OBJ_T: return "t";
192 case OBJ_INTEGER: return "integer";
193 case OBJ_IDENTIFIER: return "identifier";
194 case OBJ_STRING: return "string";
195 case OBJ_CONS: return "cons";
196 default: assert(0);
197 }
198 }
199
print_obj_lists(void)200 void print_obj_lists(void)
201 {
202 objectp p;
203 warnx(":: used objects");
204 for (p = used_objs_list; p != NULL; p = p->next)
205 warnx(":: %p (%s)", p, obj_type_str(p));
206 warnx(":: free objects");
207 for (p = free_objs_list; p != NULL; p = p->next)
208 warnx(":: %p (%s)", p, obj_type_str(p));
209 }
210 #endif
211
212 /*--------------------------------------------------------------------------
213 * Poor-man garbage collection functions.
214 *--------------------------------------------------------------------------*/
215
216 /* The integer used for tagging the Lisp objects. */
217 static int gc_id = 0;
218
tag_tree(objectp p)219 static void tag_tree(objectp p)
220 {
221 if (p->gc == gc_id)
222 return;
223
224 p->gc = gc_id;
225
226 if (p->type == OBJ_CONS) {
227 tag_tree(p->value.c.car);
228 tag_tree(p->value.c.cdr);
229 }
230 }
231
tag_whole_tree(void)232 static void tag_whole_tree(void)
233 {
234 object_pairp p;
235
236 for (p = setobjs_list; p != NULL; p = p->next) {
237 tag_tree(p->name);
238 tag_tree(p->value);
239 }
240 }
241
do_garbage_collect(void)242 static void do_garbage_collect(void)
243 {
244 objectp p, new_used_objs_list = t, next;
245
246 tag_whole_tree();
247
248 /*
249 * Search in the object vector.
250 */
251 for (p = used_objs_list; p != NULL && p != t; p = next) {
252 next = p->next;
253 if (p->gc != gc_id) {
254 /* Remove unreferenced object. */
255 #ifdef DEBUG
256 warnx(":: collecting cons %p", p);
257 #endif
258 switch (p->type) {
259 case OBJ_STRING:
260 free(p->value.s);
261 break;
262 case OBJ_IDENTIFIER:
263 free(p->value.id);
264 break;
265 }
266
267 p->next = free_objs_list;
268 free_objs_list = p;
269
270 ++free_objs;
271 --used_objs;
272 } else {
273 /* The object is referenced somewhere. */
274 p->next = new_used_objs_list;
275 new_used_objs_list = p;
276 }
277 }
278
279 used_objs_list = new_used_objs_list;
280 }
281
garbage_collect(void)282 void garbage_collect(void)
283 {
284 if (++gc_id == INT_MAX)
285 gc_id = 1;
286 do_garbage_collect();
287 }
288