1 /* list.c
2 *
3 * $Id$
4 *
5 * Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin
6 * Copyright 2002, 2003 Sam Hocevar <sam@hocevar.net>, Paris
7 *
8 * This software was derived from Elk 1.2, which was Copyright 1987, 1988,
9 * 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written
10 * by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project
11 * between TELES and Nixdorf Microprocessor Engineering, Berlin).
12 *
13 * Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co-
14 * owners or individual owners of copyright in this software, grant to any
15 * person or company a worldwide, royalty free, license to
16 *
17 * i) copy this software,
18 * ii) prepare derivative works based on this software,
19 * iii) distribute copies of this software or derivative works,
20 * iv) perform this software, or
21 * v) display this software,
22 *
23 * provided that this notice is not removed and that neither Oliver Laumann
24 * nor Teles nor Nixdorf are deemed to have made any representations as to
25 * the suitability of this software for any purpose nor are held responsible
26 * for any defects of this software.
27 *
28 * THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
29 */
30
31 #include "config.h"
32
33 #include "kernel.h"
34
35 extern unsigned int Stack_Size ();
36 extern void Uncatchable_Error (char *);
37
Const_Cons(Object car,Object cdr)38 Object Const_Cons (Object car, Object cdr) {
39 Object ret;
40
41 ret = P_Cons (car, cdr);
42 SETCONST(ret);
43 return ret;
44 }
45
P_Cons(Object car,Object cdr)46 Object P_Cons (Object car, Object cdr) {
47 Object cell;
48 GC_Node2;
49
50 #ifdef GENERATIONAL_GC
51 GC_Link2 (car, cdr);
52 cell = Alloc_Object (sizeof (struct S_Pair), T_Pair, 0);
53 GC_Unlink;
54 #else
55 /* This is an optimization (it duplicates parts of Alloc_Object()):
56 */
57
58 register char *p;
59
60 p = Hp;
61 ELK_ALIGN(p);
62 if (p + sizeof (struct S_Pair) <= Heap_End && !GC_Debug) {
63 Hp = p + sizeof (struct S_Pair);
64 SET(cell, T_Pair, (struct S_Pair *)p);
65 } else {
66 GC_Link2 (car, cdr);
67 cell = Alloc_Object (sizeof (struct S_Pair), T_Pair, 0);
68 GC_Unlink;
69 }
70 #endif
71 Car (cell) = car;
72 Cdr (cell) = cdr;
73 return cell;
74 }
75
P_Car(Object x)76 Object P_Car (Object x) {
77 Check_Type (x, T_Pair);
78 return Car (x);
79 }
80
P_Cdr(Object x)81 Object P_Cdr (Object x) {
82 Check_Type (x, T_Pair);
83 return Cdr (x);
84 }
85
Cxr(Object x,register char * pat,register unsigned int len)86 Object Cxr (Object x, register char *pat, register unsigned int len) {
87 Object ret;
88
89 for (ret = x, pat += len; len > 0; len--)
90 switch (*--pat) {
91 case 'a': ret = P_Car (ret); break;
92 case 'd': ret = P_Cdr (ret); break;
93 default: Primitive_Error ("invalid pattern");
94 }
95 return ret;
96 }
97
P_Cddr(Object x)98 Object P_Cddr (Object x) { return Cxr (x, "dd", 2); }
P_Cdar(Object x)99 Object P_Cdar (Object x) { return Cxr (x, "da", 2); }
P_Cadr(Object x)100 Object P_Cadr (Object x) { return Cxr (x, "ad", 2); }
P_Caar(Object x)101 Object P_Caar (Object x) { return Cxr (x, "aa", 2); }
102
P_Cdddr(Object x)103 Object P_Cdddr (Object x) { return Cxr (x, "ddd", 3); }
P_Cddar(Object x)104 Object P_Cddar (Object x) { return Cxr (x, "dda", 3); }
P_Cdadr(Object x)105 Object P_Cdadr (Object x) { return Cxr (x, "dad", 3); }
P_Cdaar(Object x)106 Object P_Cdaar (Object x) { return Cxr (x, "daa", 3); }
P_Caddr(Object x)107 Object P_Caddr (Object x) { return Cxr (x, "add", 3); }
P_Cadar(Object x)108 Object P_Cadar (Object x) { return Cxr (x, "ada", 3); }
P_Caadr(Object x)109 Object P_Caadr (Object x) { return Cxr (x, "aad", 3); }
P_Caaar(Object x)110 Object P_Caaar (Object x) { return Cxr (x, "aaa", 3); }
111
P_Caaaar(Object x)112 Object P_Caaaar (Object x) { return Cxr (x, "aaaa", 4); }
P_Caaadr(Object x)113 Object P_Caaadr (Object x) { return Cxr (x, "aaad", 4); }
P_Caadar(Object x)114 Object P_Caadar (Object x) { return Cxr (x, "aada", 4); }
P_Caaddr(Object x)115 Object P_Caaddr (Object x) { return Cxr (x, "aadd", 4); }
P_Cadaar(Object x)116 Object P_Cadaar (Object x) { return Cxr (x, "adaa", 4); }
P_Cadadr(Object x)117 Object P_Cadadr (Object x) { return Cxr (x, "adad", 4); }
P_Caddar(Object x)118 Object P_Caddar (Object x) { return Cxr (x, "adda", 4); }
P_Cadddr(Object x)119 Object P_Cadddr (Object x) { return Cxr (x, "addd", 4); }
P_Cdaaar(Object x)120 Object P_Cdaaar (Object x) { return Cxr (x, "daaa", 4); }
P_Cdaadr(Object x)121 Object P_Cdaadr (Object x) { return Cxr (x, "daad", 4); }
P_Cdadar(Object x)122 Object P_Cdadar (Object x) { return Cxr (x, "dada", 4); }
P_Cdaddr(Object x)123 Object P_Cdaddr (Object x) { return Cxr (x, "dadd", 4); }
P_Cddaar(Object x)124 Object P_Cddaar (Object x) { return Cxr (x, "ddaa", 4); }
P_Cddadr(Object x)125 Object P_Cddadr (Object x) { return Cxr (x, "ddad", 4); }
P_Cdddar(Object x)126 Object P_Cdddar (Object x) { return Cxr (x, "ddda", 4); }
P_Cddddr(Object x)127 Object P_Cddddr (Object x) { return Cxr (x, "dddd", 4); }
128
P_Cxr(Object x,Object pat)129 Object P_Cxr (Object x, Object pat) {
130 Check_List (x);
131 if (TYPE(pat) == T_Symbol)
132 pat = SYMBOL(pat)->name;
133 else if (TYPE(pat) != T_String)
134 Wrong_Type_Combination (pat, "string or symbol");
135 return Cxr (x, STRING(pat)->data, STRING(pat)->size);
136 }
137
P_Nullp(Object x)138 Object P_Nullp (Object x) {
139 return Nullp (x) ? True : False;
140 }
141
P_Pairp(Object x)142 Object P_Pairp (Object x) {
143 return TYPE(x) == T_Pair ? True : False;
144 }
145
P_Listp(Object x)146 Object P_Listp (Object x) {
147 Object s;
148 register int f;
149
150 for (s = x, f = 0; !Nullp (x); f ^= 1) {
151 if (TYPE(x) != T_Pair)
152 return False;
153 x = Cdr (x);
154 if (EQ(x, s))
155 return False;
156 if (f) s = Cdr (s);
157 }
158 return True;
159 }
160
P_Set_Car(Object x,Object new)161 Object P_Set_Car (Object x, Object new) {
162 Check_Type (x, T_Pair);
163 Check_Mutable (x);
164 Car (x) = new;
165 return new;
166 }
167
P_Set_Cdr(Object x,Object new)168 Object P_Set_Cdr (Object x, Object new) {
169 Check_Type (x, T_Pair);
170 Check_Mutable (x);
171 Cdr (x) = new;
172 return new;
173 }
174
General_Member(Object key,Object list,register int comp)175 Object General_Member (Object key, Object list, register int comp) {
176 register int r;
177
178 for ( ; !Nullp (list); list = Cdr (list)) {
179 Check_List (list);
180 if (comp == 0)
181 r = EQ(Car (list), key);
182 else if (comp == 1)
183 r = Eqv (Car (list), key);
184 else
185 r = Equal (Car (list), key);
186 if (r) return list;
187 }
188 return False;
189 }
190
P_Memq(Object key,Object list)191 Object P_Memq (Object key, Object list) {
192 return General_Member (key, list, 0);
193 }
194
P_Memv(Object key,Object list)195 Object P_Memv (Object key, Object list) {
196 return General_Member (key, list, 1);
197 }
198
P_Member(Object key,Object list)199 Object P_Member (Object key, Object list) {
200 return General_Member (key, list, 2);
201 }
202
General_Assoc(Object key,Object alist,register int comp)203 Object General_Assoc (Object key, Object alist, register int comp) {
204 Object elem;
205 register int r;
206
207 for ( ; !Nullp (alist); alist = Cdr (alist)) {
208 Check_List (alist);
209 elem = Car (alist);
210 if (TYPE(elem) != T_Pair)
211 continue;
212 if (comp == 0)
213 r = EQ(Car (elem), key);
214 else if (comp == 1)
215 r = Eqv (Car (elem), key);
216 else
217 r = Equal (Car (elem), key);
218 if (r) return elem;
219 }
220 return False;
221 }
222
P_Assq(Object key,Object alist)223 Object P_Assq (Object key, Object alist) {
224 return General_Assoc (key, alist, 0);
225 }
226
P_Assv(Object key,Object alist)227 Object P_Assv (Object key, Object alist) {
228 return General_Assoc (key, alist, 1);
229 }
230
P_Assoc(Object key,Object alist)231 Object P_Assoc (Object key, Object alist) {
232 return General_Assoc (key, alist, 2);
233 }
234
Fast_Length(Object list)235 unsigned int Fast_Length (Object list) {
236 Object tail;
237 register int i;
238
239 for (i = 0, tail = list; TYPE(tail) == T_Pair; tail = Cdr (tail), i++)
240 ;
241 return i;
242 }
243
P_Length(Object list)244 Object P_Length (Object list) {
245 Object tail;
246 register int i;
247
248 for (i = 0, tail = list; !Nullp (tail); tail = Cdr (tail), i++)
249 Check_List (tail);
250 return Make_Integer (i);
251 }
252
P_Make_List(Object n,Object init)253 Object P_Make_List (Object n, Object init) {
254 register unsigned int len;
255 Object list;
256 GC_Node;
257
258 if ((len = Get_Exact_Integer (n)) < 0)
259 Range_Error (n);
260 list = Null;
261 GC_Link (init);
262 while (len-- > 0)
263 list = Cons (init, list);
264 GC_Unlink;
265 return list;
266 }
267
P_List(int argc,Object * argv)268 Object P_List (int argc, Object *argv) {
269 Object list, tail, cell;
270 GC_Node2;
271
272 GC_Link2 (list, tail);
273 for (list = tail = Null; argc-- > 0; tail = cell) {
274 cell = Cons (*argv++, Null);
275 if (Nullp (list))
276 list = cell;
277 else
278 (void)P_Set_Cdr (tail, cell);
279 }
280 GC_Unlink;
281 return list;
282 }
283
P_Last_Pair(Object x)284 Object P_Last_Pair (Object x) {
285 Check_Type (x, T_Pair);
286 for ( ; TYPE(Cdr (x)) == T_Pair; x = Cdr (x)) ;
287 return x;
288 }
289
P_Append(int argc,Object * argv)290 Object P_Append (int argc, Object *argv) {
291 Object list, last, tail, cell;
292 register int i;
293 GC_Node3;
294
295 list = last = Null;
296 GC_Link3 (list, last, tail);
297 for (i = 0; i < argc-1; i++) {
298 for (tail = argv[i]; !Nullp (tail); tail = Cdr (tail)) {
299 Check_List (tail);
300 cell = Cons (Car (tail), Null);
301 if (Nullp (list))
302 list = cell;
303 else
304 (void)P_Set_Cdr (last, cell);
305 last = cell;
306 }
307 }
308 if (argc) {
309 if (Nullp (list))
310 list = argv[i];
311 else
312 (void)P_Set_Cdr (last, argv[i]);
313 }
314 GC_Unlink;
315 return list;
316 }
317
P_Append_Set(int argc,Object * argv)318 Object P_Append_Set (int argc, Object *argv) {
319 register int i, j;
320
321 for (i = j = 0; i < argc; i++)
322 if (!Nullp (argv[i]))
323 argv[j++] = argv[i];
324 if (j == 0)
325 return Null;
326 for (i = 0; i < j-1; i++)
327 (void)P_Set_Cdr (P_Last_Pair (argv[i]), argv[i+1]);
328 return *argv;
329 }
330
P_Reverse(Object x)331 Object P_Reverse (Object x) {
332 Object ret;
333 GC_Node;
334
335 GC_Link (x);
336 for (ret = Null; !Nullp (x); x = Cdr (x)) {
337 Check_List (x);
338 ret = Cons (Car (x), ret);
339 }
340 GC_Unlink;
341 return ret;
342 }
343
P_Reverse_Set(Object x)344 Object P_Reverse_Set (Object x) {
345 Object prev, tail;
346
347 for (prev = Null; !Nullp (x); prev = x, x = tail) {
348 Check_List (x);
349 tail = Cdr (x);
350 (void)P_Set_Cdr (x, prev);
351 }
352 return prev;
353 }
354
P_List_Tail(Object x,Object num)355 Object P_List_Tail (Object x, Object num) {
356 register int n;
357
358 for (n = Get_Exact_Integer (num); n > 0 && !Nullp (x); n--, x = P_Cdr (x))
359 ;
360 return x;
361 }
362
P_List_Ref(Object x,Object num)363 Object P_List_Ref (Object x, Object num) {
364 return P_Car (P_List_Tail (x, num));
365 }
366
Copy_List(Object x)367 Object Copy_List (Object x) {
368 Object car, cdr;
369 GC_Node3;
370
371 if (TYPE(x) == T_Pair) {
372 if (Stack_Size () > Max_Stack)
373 Uncatchable_Error ("Out of stack space");
374 car = cdr = Null;
375 GC_Link3 (x, car, cdr);
376 car = Copy_List (Car (x));
377 cdr = Copy_List (Cdr (x));
378 x = Cons (car, cdr);
379 GC_Unlink;
380 }
381 return x;
382 }
383