1 /*
2 * list.c - List related functions
3 *
4 * Copyright (c) 2000-2020 Shiro Kawai <shiro@acm.org>
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 *
10 * 1. Redistributions of source code must retain the above copyright
11 * notice, this list of conditions and the following disclaimer.
12 *
13 * 2. Redistributions in binary form must reproduce the above copyright
14 * notice, this list of conditions and the following disclaimer in the
15 * documentation and/or other materials provided with the distribution.
16 *
17 * 3. Neither the name of the authors nor the names of its contributors
18 * may be used to endorse or promote products derived from this
19 * software without specific prior written permission.
20 *
21 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32 */
33
34 #define LIBGAUCHE_BODY
35 #include "gauche.h"
36 #include "gauche/priv/pairP.h"
37
38 /*
39 * Classes
40 */
41
42 static ScmClass *list_cpl[] = {
43 SCM_CLASS_STATIC_PTR(Scm_ListClass),
44 SCM_CLASS_STATIC_PTR(Scm_SequenceClass),
45 SCM_CLASS_STATIC_PTR(Scm_CollectionClass),
46 SCM_CLASS_STATIC_PTR(Scm_TopClass),
47 NULL
48 };
49
50 SCM_DEFINE_BUILTIN_CLASS(Scm_ListClass, NULL, NULL, NULL, NULL, list_cpl+1);
51 SCM_DEFINE_BUILTIN_CLASS(Scm_PairClass, NULL, NULL, NULL, NULL, list_cpl);
52 SCM_DEFINE_BUILTIN_CLASS(Scm_NullClass, NULL, NULL, NULL, NULL, list_cpl);
53
54 /*
55 * CONSTRUCTOR
56 */
57
Scm_Cons(ScmObj car,ScmObj cdr)58 ScmObj Scm_Cons(ScmObj car, ScmObj cdr)
59 {
60 ScmPair *z = SCM_NEW(ScmPair);
61 /* NB: these ENSURE_MEMs are moved here from vm loop to reduce
62 the register pressure there. In most cases these increases
63 just a couple of mask-and-test instructions on the data on
64 the register. */
65 SCM_FLONUM_ENSURE_MEM(car);
66 SCM_FLONUM_ENSURE_MEM(cdr);
67 SCM_SET_CAR_UNCHECKED(z, car);
68 SCM_SET_CDR_UNCHECKED(z, cdr);
69 return SCM_OBJ(z);
70 }
71
Scm_Acons(ScmObj caar,ScmObj cdar,ScmObj cdr)72 ScmObj Scm_Acons(ScmObj caar, ScmObj cdar, ScmObj cdr)
73 {
74 ScmPair *y = SCM_NEW(ScmPair);
75 ScmPair *z = SCM_NEW(ScmPair);
76 SCM_SET_CAR_UNCHECKED(y, caar);
77 SCM_SET_CDR_UNCHECKED(y, cdar);
78 SCM_SET_CAR_UNCHECKED(z, SCM_OBJ(y));
79 SCM_SET_CDR_UNCHECKED(z, cdr);
80 return SCM_OBJ(z);
81 }
82
Scm_List(ScmObj elt,...)83 ScmObj Scm_List(ScmObj elt, ...)
84 {
85 if (elt == NULL) return SCM_NIL;
86
87 va_list pvar;
88 va_start(pvar, elt);
89 ScmObj cdr = Scm_VaList(pvar);
90 va_end(pvar);
91 return Scm_Cons(elt, cdr);
92 }
93
94
Scm_Conses(ScmObj elt,...)95 ScmObj Scm_Conses(ScmObj elt, ...)
96 {
97 if (elt == NULL) return SCM_NIL;
98
99 va_list pvar;
100 va_start(pvar, elt);
101 ScmObj cdr = Scm_VaCons(pvar);
102 va_end(pvar);
103 if (cdr == NULL) return elt;
104 else return Scm_Cons(elt, cdr);
105 }
106
107
Scm_VaList(va_list pvar)108 ScmObj Scm_VaList(va_list pvar)
109 {
110 ScmObj start = SCM_NIL, cp = SCM_NIL, obj;
111
112 for (obj = va_arg(pvar, ScmObj);
113 obj != NULL;
114 obj = va_arg(pvar, ScmObj))
115 {
116 if (SCM_NULLP(start)) {
117 start = SCM_OBJ(SCM_NEW(ScmPair));
118 SCM_SET_CAR_UNCHECKED(start, obj);
119 SCM_SET_CDR_UNCHECKED(start, SCM_NIL);
120 cp = start;
121 } else {
122 ScmObj item;
123 item = SCM_OBJ(SCM_NEW(ScmPair));
124 SCM_SET_CDR_UNCHECKED(cp, item);
125 SCM_SET_CAR_UNCHECKED(item, obj);
126 SCM_SET_CDR_UNCHECKED(item, SCM_NIL);
127 cp = item;
128 }
129 }
130 return start;
131 }
132
133
Scm_VaCons(va_list pvar SCM_UNUSED)134 ScmObj Scm_VaCons(va_list pvar SCM_UNUSED)
135 {
136 Scm_Panic("Scm_VaCons: not implemented");
137 return SCM_UNDEFINED;
138 }
139
Scm_ArrayToList(ScmObj * elts,ScmSize nelts)140 ScmObj Scm_ArrayToList(ScmObj *elts, ScmSize nelts)
141 {
142 return Scm_ArrayToListWithTail(elts, nelts, SCM_NIL);
143 }
144
Scm_ArrayToListWithTail(ScmObj * elts,ScmSize nelts,ScmObj tail)145 ScmObj Scm_ArrayToListWithTail(ScmObj *elts, ScmSize nelts, ScmObj tail)
146 {
147 ScmObj h = SCM_NIL, t = SCM_NIL;
148 if (elts) {
149 for (ScmSize i=0; i<nelts; i++) SCM_APPEND1(h, t, *elts++);
150 }
151 if (!SCM_NULLP(tail)) SCM_APPEND(h, t, tail);
152 return h;
153 }
154
Scm_ListToArray(ScmObj list,ScmSize * nelts,ScmObj * store,int alloc)155 ScmObj *Scm_ListToArray(ScmObj list, ScmSize *nelts, ScmObj *store, int alloc)
156 {
157 ScmSize len = Scm_Length(list);
158 if (len < 0) Scm_Error("proper list required, but got %S", list);
159
160 ScmObj *array;
161 if (store == NULL) {
162 array = SCM_NEW_ARRAY(ScmObj, len);
163 } else {
164 if (*nelts < len) {
165 if (!alloc)
166 Scm_Error("ListToArray: storage too small");
167 array = SCM_NEW_ARRAY(ScmObj, len);
168 } else {
169 array = store;
170 }
171 }
172 ScmSize i = 0;
173 for (ScmObj lp=list; i<len; i++, lp=SCM_CDR(lp)) {
174 array[i] = SCM_CAR(lp);
175 }
176 *nelts = len;
177 return array;
178 }
179
180 /* cXr stuff */
181
182 #define CXR(cname, sname, body) \
183 ScmObj cname (ScmObj obj) \
184 { \
185 ScmObj obj2 = obj; \
186 body \
187 return obj2; \
188 }
189
190 #define A \
191 if (!SCM_PAIRP(obj2)) Scm_Error("bad object: %S", obj); \
192 obj2 = SCM_CAR(obj2);
193
194 #define D \
195 if (!SCM_PAIRP(obj2)) Scm_Error("bad object: %S", obj); \
196 obj2 = SCM_CDR(obj2);
197
198 CXR(Scm_Car, "car", A)
199 CXR(Scm_Cdr, "cdr", D)
200 CXR(Scm_Caar, "caar", A A)
201 CXR(Scm_Cadr, "cadr", D A)
202 CXR(Scm_Cdar, "cdar", A D)
203 CXR(Scm_Cddr, "cddr", D D)
204
Scm_SetCar(ScmObj pair,ScmObj obj)205 void Scm_SetCar(ScmObj pair, ScmObj obj)
206 {
207 if (!SCM_PAIRP(pair)) {
208 Scm_Error("set-car!: Pair required, but got: %S", pair);
209 }
210 ScmExtendedPairDescriptor *d = Scm__GetExtendedPairDescriptor(pair);
211 if (d) {
212 if (d->flags & SCM_PAIR_IMMUTABLE) {
213 Scm_Error("attempt to mutate car of an immutable pair %S with %S",
214 pair, obj);
215 }
216 if (d->setCar) {
217 d->setCar(pair, obj);
218 return;
219 }
220 }
221 SCM_CAR(pair) = obj;
222 }
223
Scm_SetCdr(ScmObj pair,ScmObj obj)224 void Scm_SetCdr(ScmObj pair, ScmObj obj)
225 {
226 if (!SCM_PAIRP(pair)) {
227 Scm_Error("set-cdr!: Pair required, but got: %S", pair);
228 }
229 ScmExtendedPairDescriptor *d = Scm__GetExtendedPairDescriptor(pair);
230 if (d) {
231 if (d->flags & SCM_PAIR_IMMUTABLE) {
232 Scm_Error("attempt to mutate cdr of an immutable pair %S with %S",
233 pair, obj);
234 }
235 if (d->setCdr) {
236 d->setCdr(pair, obj);
237 return;
238 }
239 }
240 SCM_CDR(pair) = obj;
241 }
242
243 /*
244 * List manipulate routines:
245 */
246
247 /* Scm_Length
248 return length of list in C integer.
249 If the argument is a dotted list, return -1.
250 If the argument is a circular list, return -2. */
251
Scm_Length(ScmObj obj)252 ScmSize Scm_Length(ScmObj obj)
253 {
254 ScmObj slow = obj;
255 ScmSize len = 0;
256
257 for (;;) {
258 if (SCM_NULLP(obj)) break;
259 if (!SCM_PAIRP(obj)) return SCM_LIST_DOTTED;
260
261 obj = SCM_CDR(obj);
262 len++;
263 if (SCM_NULLP(obj)) break;
264 if (!SCM_PAIRP(obj)) return SCM_LIST_DOTTED;
265
266 obj = SCM_CDR(obj);
267 slow = SCM_CDR(slow);
268 if (obj == slow) return SCM_LIST_CIRCULAR;
269 len++;
270 }
271 return len;
272 }
273
274 /* Scm_CopyList(list)
275 * Copy toplevel list LIST. LIST can be improper.
276 * If LIST is not a pair, return LIST itself.
277 */
278
Scm_CopyList(ScmObj list)279 ScmObj Scm_CopyList(ScmObj list)
280 {
281 if (!SCM_PAIRP(list)) return list;
282 ScmObj tortoise = list, hare = list;
283
284 ScmObj start = SCM_NIL, last = SCM_NIL;
285 for (;;) {
286 if (!SCM_PAIRP(hare)) break;
287 SCM_APPEND1(start, last, SCM_CAR(hare));
288 hare = SCM_CDR(hare);
289
290 if (!SCM_PAIRP(hare)) break;
291 SCM_APPEND1(start, last, SCM_CAR(hare));
292 hare = SCM_CDR(hare);
293 tortoise = SCM_CDR(tortoise);
294 if (hare == tortoise) {
295 Scm_Error("Attempt to copy a circular list: %S", list);
296 }
297 }
298 if (!SCM_NULLP(hare)) SCM_SET_CDR_UNCHECKED(last, hare);
299 return start;
300 }
301
302 /* Scm_MakeList(len, fill)
303 * Make a list of specified length.
304 * Note that <len> is C-integer.
305 */
306
Scm_MakeList(ScmSmallInt len,ScmObj fill)307 ScmObj Scm_MakeList(ScmSmallInt len, ScmObj fill)
308 {
309 if (len < 0) {
310 Scm_Error("make-list: negative length given: %ld", len);
311 }
312 ScmObj start = SCM_NIL, last = SCM_NIL;
313 while (len--) {
314 SCM_APPEND1(start, last, fill);
315 }
316 return start;
317 }
318
319
320 /* Scm_Append2X(list, obj)
321 * Replace cdr of last pair of LIST for OBJ.
322 * If LIST is not a pair, return OBJ.
323 */
324
Scm_Append2X(ScmObj list,ScmObj obj)325 ScmObj Scm_Append2X(ScmObj list, ScmObj obj)
326 {
327 ScmObj cp;
328 SCM_FOR_EACH(cp, list) {
329 if (SCM_NULLP(SCM_CDR(cp))) {
330 Scm_SetCdr(cp, obj);
331 return list;
332 }
333 }
334 return obj;
335 }
336
337 /* Scm_Append2(list, obj)
338 * Copy LIST and append OBJ to it.
339 * If LIST is not a pair, return OBJ.
340 */
341
Scm_Append2(ScmObj list,ScmObj obj)342 ScmObj Scm_Append2(ScmObj list, ScmObj obj)
343 {
344 if (SCM_NULLP(list)) return obj;
345
346 ScmObj cp, start = SCM_NIL, last = SCM_NIL;
347 SCM_FOR_EACH(cp, list) {
348 SCM_APPEND1(start, last, SCM_CAR(cp));
349 }
350 if (!SCM_NULLP(cp)) {
351 Scm_Error("proper list required, but got %S", list);
352 }
353 SCM_SET_CDR_UNCHECKED(last, obj);
354
355 return start;
356 }
357
Scm_Append(ScmObj args)358 ScmObj Scm_Append(ScmObj args)
359 {
360 ScmObj start = SCM_NIL, last = SCM_NIL, cp;
361 SCM_FOR_EACH(cp, args) {
362 if (!SCM_PAIRP(SCM_CDR(cp))) {
363 if (SCM_NULLP(start)) return SCM_CAR(cp);
364 SCM_SET_CDR_UNCHECKED(last, SCM_CAR(cp));
365 break;
366 } else if (SCM_NULLP(SCM_CAR(cp))) {
367 continue;
368 } else if (!SCM_PAIRP(SCM_CAR(cp))) {
369 Scm_Error("pair required, but got %S", SCM_CAR(cp));
370 } else {
371 SCM_APPEND(start, last, Scm_CopyList(SCM_CAR(cp)));
372 if (SCM_PAIRP(last) && !SCM_NULLP(SCM_CDR(last))) {
373 Scm_Error("proper list required, but got %S", SCM_CAR(cp));
374 }
375 }
376 }
377 return start;
378 }
379
380 /* Scm_Reverse2(list, tail)
381 * Reverse LIST, and append TAIL to the result.
382 * If LIST is an improper list, cdr of the last pair is ignored.
383 * If LIST is not a pair, TAIL is returned.
384 * Scm_Reverse(list)
385 * Scm_Reverse2(list, SCM_NIL). Just for the backward compatibility.
386 */
387
Scm_Reverse2(ScmObj list,ScmObj tail)388 ScmObj Scm_Reverse2(ScmObj list, ScmObj tail)
389 {
390 if (!SCM_PAIRP(list)) return tail;
391
392 ScmPair *p = SCM_NEW(ScmPair);
393 SCM_SET_CAR_UNCHECKED(p, SCM_NIL);
394 SCM_SET_CDR_UNCHECKED(p, tail);
395 ScmObj result = SCM_OBJ(p);
396 ScmObj cp;
397 SCM_FOR_EACH(cp, list) {
398 SCM_SET_CAR_UNCHECKED(result, SCM_CAR(cp));
399 p = SCM_NEW(ScmPair);
400 SCM_SET_CAR_UNCHECKED(p, SCM_NIL);
401 SCM_SET_CDR_UNCHECKED(p, result);
402 result = SCM_OBJ(p);
403 }
404 return SCM_CDR(result);
405 }
406
Scm_Reverse(ScmObj list)407 ScmObj Scm_Reverse(ScmObj list)
408 {
409 return Scm_Reverse2(list, SCM_NIL);
410 }
411
412
413 /* Scm_Reverse2X(list, tail)
414 * Return reversed list of LIST. Pairs in previous LIST is used to
415 * create new list. TAIL is appended to the result.
416 * If LIST is not a pair, returns TAIL.
417 * If LIST is an improper list, cdr of the last cell is ignored.
418 */
419
Scm_Reverse2X(ScmObj list,ScmObj tail)420 ScmObj Scm_Reverse2X(ScmObj list, ScmObj tail)
421 {
422 if (!SCM_PAIRP(list)) return tail;
423 ScmObj first, next, result = tail;
424 for (first = list; SCM_PAIRP(first); first = next) {
425 next = SCM_CDR(first);
426 Scm_SetCdr(first, result);
427 result = first;
428 }
429 return result;
430 }
431
Scm_ReverseX(ScmObj list)432 ScmObj Scm_ReverseX(ScmObj list)
433 {
434 return Scm_Reverse2X(list, SCM_NIL);
435 }
436
437 /* Scm_ListTail(list, i, fallback)
438 * Scm_ListRef(list, i, fallback)
439 * Note that i is C-INTEGER. If i is out of bound, signal error.
440 */
441
Scm_ListTail(ScmObj list,ScmSmallInt i,ScmObj fallback)442 ScmObj Scm_ListTail(ScmObj list, ScmSmallInt i, ScmObj fallback)
443 {
444 if (i < 0) goto err;
445 ScmSmallInt cnt = i;
446 while (cnt-- > 0) {
447 if (!SCM_PAIRP(list)) goto err;
448 list = SCM_CDR(list);
449 }
450 return list;
451 err:
452 if (SCM_UNBOUNDP(fallback)) Scm_Error("argument out of range: %ld", i);
453 return fallback;
454 }
455
Scm_ListRef(ScmObj list,ScmSmallInt i,ScmObj fallback)456 ScmObj Scm_ListRef(ScmObj list, ScmSmallInt i, ScmObj fallback)
457 {
458 if (i < 0) goto err;
459 for (ScmSmallInt k=0; k<i; k++) {
460 if (!SCM_PAIRP(list)) goto err;
461 list = SCM_CDR(list);
462 }
463 if (!SCM_PAIRP(list)) goto err;
464 return SCM_CAR(list);
465 err:
466 if (SCM_UNBOUNDP(fallback)) {
467 Scm_Error("argument out of range: %ld", i);
468 }
469 return fallback;
470 }
471
472 /* Scm_LastPair(l)
473 * Return last pair of (maybe improper) list L.
474 * If L is not a pair, signal error.
475 */
476
Scm_LastPair(ScmObj l)477 ScmObj Scm_LastPair(ScmObj l)
478 {
479 if (!SCM_PAIRP(l)) Scm_Error("pair required: %S", l);
480
481 ScmObj cp;
482 SCM_FOR_EACH(cp, l) {
483 ScmObj cdr = SCM_CDR(cp);
484 if (!SCM_PAIRP(cdr)) return cp;
485 }
486 return SCM_UNDEFINED; /* NOTREACHED */
487 }
488
489 /* Scm_Memq(obj, list)
490 * Scm_Memv(obj, list)
491 * Scm_Member(obj, list)
492 * LIST must be a list. Return the first sublist whose car is obj.
493 * If obj doesn't occur in LIST, or LIST is not a pair, #f is returned.
494 */
495
Scm_Memq(ScmObj obj,ScmObj list)496 ScmObj Scm_Memq(ScmObj obj, ScmObj list)
497 {
498 SCM_FOR_EACH(list, list) if (obj == SCM_CAR(list)) return list;
499 return SCM_FALSE;
500 }
501
Scm_Memv(ScmObj obj,ScmObj list)502 ScmObj Scm_Memv(ScmObj obj, ScmObj list)
503 {
504 SCM_FOR_EACH(list, list) {
505 if (Scm_EqvP(obj, SCM_CAR(list))) return list;
506 }
507 return SCM_FALSE;
508 }
509
Scm_Member(ScmObj obj,ScmObj list,int cmpmode)510 ScmObj Scm_Member(ScmObj obj, ScmObj list, int cmpmode)
511 {
512 SCM_FOR_EACH(list, list) {
513 if (Scm_EqualM(obj, SCM_CAR(list), cmpmode)) return list;
514 }
515 return SCM_FALSE;
516 }
517
518 /* delete. */
Scm_Delete(ScmObj obj,ScmObj list,int cmpmode)519 ScmObj Scm_Delete(ScmObj obj, ScmObj list, int cmpmode)
520 {
521 if (SCM_NULLP(list)) return SCM_NIL;
522
523 ScmObj start = SCM_NIL, last = SCM_NIL, cp, prev = list;
524 SCM_FOR_EACH(cp, list) {
525 if (Scm_EqualM(obj, SCM_CAR(cp), cmpmode)) {
526 for (; prev != cp; prev = SCM_CDR(prev))
527 SCM_APPEND1(start, last, SCM_CAR(prev));
528 prev = SCM_CDR(cp);
529 }
530 }
531 if (list == prev) return list;
532 if (SCM_NULLP(start)) return prev;
533 if (SCM_PAIRP(prev)) SCM_SET_CDR(last, prev);
534 return start;
535 }
536
Scm_DeleteX(ScmObj obj,ScmObj list,int cmpmode)537 ScmObj Scm_DeleteX(ScmObj obj, ScmObj list, int cmpmode)
538 {
539 ScmObj cp, prev = SCM_NIL;
540 SCM_FOR_EACH(cp, list) {
541 if (Scm_EqualM(obj, SCM_CAR(cp), cmpmode)) {
542 if (SCM_NULLP(prev)) {
543 list = SCM_CDR(cp);
544 } else {
545 Scm_SetCdr(prev, SCM_CDR(cp));
546 }
547 } else {
548 prev = cp;
549 }
550 }
551 return list;
552 }
553
554
555 /*
556 * assq, assv, assoc
557 * ALIST must be a list of pairs. Return the first pair whose car
558 * is obj. If ALIST contains non pair, it's silently ignored.
559 */
560
Scm_Assq(ScmObj obj,ScmObj alist)561 ScmObj Scm_Assq(ScmObj obj, ScmObj alist)
562 {
563 if (!SCM_LISTP(alist)) Scm_Error("assq: list required, but got %S", alist);
564 ScmObj cp;
565 SCM_FOR_EACH(cp,alist) {
566 ScmObj entry = SCM_CAR(cp);
567 if (!SCM_PAIRP(entry)) continue;
568 if (obj == SCM_CAR(entry)) return entry;
569 }
570 return SCM_FALSE;
571 }
572
Scm_Assv(ScmObj obj,ScmObj alist)573 ScmObj Scm_Assv(ScmObj obj, ScmObj alist)
574 {
575 if (!SCM_LISTP(alist)) Scm_Error("assv: list required, but got %S", alist);
576 ScmObj cp;
577 SCM_FOR_EACH(cp,alist) {
578 ScmObj entry = SCM_CAR(cp);
579 if (!SCM_PAIRP(entry)) continue;
580 if (Scm_EqvP(obj, SCM_CAR(entry))) return entry;
581 }
582 return SCM_FALSE;
583 }
584
Scm_Assoc(ScmObj obj,ScmObj alist,int cmpmode)585 ScmObj Scm_Assoc(ScmObj obj, ScmObj alist, int cmpmode)
586 {
587 if (!SCM_LISTP(alist)) Scm_Error("assoc: list required, but got %S", alist);
588 ScmObj cp;
589 SCM_FOR_EACH(cp,alist) {
590 ScmObj entry = SCM_CAR(cp);
591 if (!SCM_PAIRP(entry)) continue;
592 if (Scm_EqualM(obj, SCM_CAR(entry), cmpmode)) return entry;
593 }
594 return SCM_FALSE;
595 }
596
597 /* Assoc-delete */
Scm_AssocDelete(ScmObj elt,ScmObj alist,int cmpmode)598 ScmObj Scm_AssocDelete(ScmObj elt, ScmObj alist, int cmpmode)
599 {
600 if (!SCM_LISTP(alist)) {
601 Scm_Error("assoc-delete: list required, but got %S", alist);
602 }
603 if (SCM_NULLP(alist)) return SCM_NIL;
604
605 ScmObj start = SCM_NIL, last = SCM_NIL, cp, p, prev = alist;
606 SCM_FOR_EACH(cp, alist) {
607 p = SCM_CAR(cp);
608 if (SCM_PAIRP(p)) {
609 if (Scm_EqualM(elt, SCM_CAR(p), cmpmode)) {
610 for (; prev != cp; prev = SCM_CDR(prev))
611 SCM_APPEND1(start, last, SCM_CAR(prev));
612 prev = SCM_CDR(cp);
613 }
614 }
615 }
616 if (alist == prev) return alist;
617 if (SCM_NULLP(start)) return prev;
618 if (SCM_PAIRP(prev)) SCM_SET_CDR(last, prev);
619 return start;
620 }
621
Scm_AssocDeleteX(ScmObj elt,ScmObj alist,int cmpmode)622 ScmObj Scm_AssocDeleteX(ScmObj elt, ScmObj alist, int cmpmode)
623 {
624 if (!SCM_LISTP(alist)) {
625 Scm_Error("assoc-delete!: list required, but got %S", alist);
626 }
627 ScmObj cp, prev = SCM_NIL;
628 SCM_FOR_EACH(cp, alist) {
629 ScmObj e = SCM_CAR(cp);
630 if (SCM_PAIRP(e)) {
631 if (Scm_EqualM(elt, SCM_CAR(e), cmpmode)) {
632 if (SCM_NULLP(prev)) {
633 alist = SCM_CDR(cp);
634 continue;
635 } else {
636 Scm_SetCdr(prev, SCM_CDR(cp));
637 }
638 }
639 }
640 prev = cp;
641 }
642 return alist;
643 }
644
645 /* DeleteDuplicates. preserve the order of original list. N^2 algorithm */
646
Scm_DeleteDuplicates(ScmObj list,int cmpmode)647 ScmObj Scm_DeleteDuplicates(ScmObj list, int cmpmode)
648 {
649 ScmObj result = SCM_NIL, tail = SCM_NIL, lp;
650 SCM_FOR_EACH(lp, list) {
651 if (SCM_FALSEP(Scm_Member(SCM_CAR(lp), result, cmpmode))) {
652 SCM_APPEND1(result, tail, SCM_CAR(lp));
653 }
654 }
655 if (!SCM_NULLP(lp) && !SCM_NULLP(tail)) SCM_SET_CDR(tail, lp);
656 return result;
657 }
658
Scm_DeleteDuplicatesX(ScmObj list,int cmpmode)659 ScmObj Scm_DeleteDuplicatesX(ScmObj list, int cmpmode)
660 {
661 ScmObj lp;
662
663 SCM_FOR_EACH(lp, list) {
664 ScmObj obj = SCM_CAR(lp);
665 ScmObj tail = Scm_DeleteX(obj, SCM_CDR(lp), cmpmode);
666 if (SCM_CDR(lp) != tail) Scm_SetCdr(lp, tail);
667 }
668 return list;
669 }
670
671 /*
672 * Monotonic Merge
673 *
674 * Merge lists, keeping the order of elements (left to right) in each
675 * list. If there's more than one way to order an element, choose the
676 * first one appears in the given list of lists.
677 * Returns SCM_FALSE if the lists are inconsistent to be ordered
678 * in the way.
679 *
680 * START is an item of the starting point. It is inserted into the result
681 * first. SEQUENCES is a list of lists describing the order of preference.
682 *
683 * The algorithm is used in C3 linearization of class precedence
684 * calculation, described in the paper
685 * http://www.webcom.com/~haahr/dylan/linearization-oopsla96.html.
686 * Since the algorithm is generally useful, I implement the core routine
687 * of the algorithm here.
688 *
689 * TRANSIENT: I noticed START argument actually isn't used in the
690 * algorithm at all. We can drop it and the caller can just say
691 * Scm_Cons(start, Scm_MonotonicMerge(sequences)). We can't change it
692 * now because of ABI compatibility, but it will be nice to do so when
693 * releasing 1.0.
694 */
695
696 #if GAUCHE_API_VERSION < 1000
Scm_MonotonicMerge(ScmObj start,ScmObj sequences)697 ScmObj Scm_MonotonicMerge(ScmObj start, ScmObj sequences)
698 {
699 ScmObj r = Scm_MonotonicMerge1(sequences);
700 if (!SCM_FALSEP(r)) r = Scm_Cons(start, r);
701 return r;
702 }
Scm_MonotonicMerge1(ScmObj sequences)703 ScmObj Scm_MonotonicMerge1(ScmObj sequences)
704 #else /*GAUCHE_API_VERSION >= 1000 */
705 ScmObj Scm_MonotonicMerge(ScmObj sequences)
706 #endif /*GAUCHE_API_VERSION >= 1000 */
707 {
708 ScmObj result = SCM_NIL;
709 int nseqs = Scm_Length(sequences);
710 if (nseqs < 0) Scm_Error("bad list of sequences: %S", sequences);
711 ScmObj *seqv = SCM_NEW_ARRAY(ScmObj, nseqs);
712 for (ScmObj *sp=seqv;
713 SCM_PAIRP(sequences);
714 sp++, sequences=SCM_CDR(sequences)) {
715 *sp = SCM_CAR(sequences);
716 }
717
718 for (;;) {
719 /* have we consumed all the inputs? */
720 ScmObj *sp;
721 for (sp=seqv; sp<seqv+nseqs; sp++) {
722 if (!SCM_NULLP(*sp)) break;
723 }
724 if (sp == seqv+nseqs) return Scm_ReverseX(result);
725
726 /* select candidate */
727 ScmObj next = SCM_FALSE;
728 for (sp = seqv; sp < seqv+nseqs; sp++) {
729 if (!SCM_PAIRP(*sp)) continue;
730 ScmObj h = SCM_CAR(*sp);
731 ScmObj *tp;
732 for (tp = seqv; tp < seqv+nseqs; tp++) {
733 if (!SCM_PAIRP(*tp)) continue;
734 if (!SCM_FALSEP(Scm_Memq(h, SCM_CDR(*tp)))) {
735 break;
736 }
737 }
738 if (tp != seqv+nseqs) continue;
739 next = h;
740 break;
741 }
742
743 if (SCM_FALSEP(next)) return SCM_FALSE; /* inconsistent */
744
745 /* move the candidate to the result */
746 result = Scm_Cons(next, result);
747 for (sp = seqv; sp < seqv+nseqs; sp++) {
748 if (SCM_PAIRP(*sp) && SCM_EQ(next, SCM_CAR(*sp))) {
749 *sp = SCM_CDR(*sp);
750 }
751 }
752 }
753 /* NOTREACHED */
754 }
755
756 /*
757 * Extended pairs
758 */
759
make_extended_pair(ScmExtendedPairDescriptor * desc,ScmObj car,ScmObj cdr,ScmObj attrs)760 static ScmObj make_extended_pair(ScmExtendedPairDescriptor *desc,
761 ScmObj car, ScmObj cdr, ScmObj attrs)
762 {
763 ScmRealExtendedPair *xp = SCM_NEW(ScmRealExtendedPair);
764 /* ScmRealExtendedPair is not an ScmObj, and
765 ScmExtendedPairDescriptor is not an ScmClass. To avoid confusion,
766 we manually tweak tag bits.
767 */
768 xp->hiddenTag = SCM_WORD((ScmByte*)desc + 7);
769 xp->data.car = car;
770 xp->data.cdr = cdr;
771 xp->data.attributes = attrs;
772 return SCM_OBJ(&xp->data); /* hide the first word */
773 }
774
775 /* "vanilla" extended pair. used mainly to hold extra attributes, but
776 otherwise behaves like normal pairs.
777 NB: Static initialization with ScmClass* requires extra care on
778 Windows. To avoid complication, we initialize the klass field in
779 _Init() routine.
780 */
781 static ScmExtendedPairDescriptor mpair_desc = {
782 NULL, /* will be SCM_CLASS_PAIR */
783 0,
784 NULL,
785 NULL
786 };
787
Scm_MakeExtendedPair(ScmObj car,ScmObj cdr,ScmObj attrs)788 ScmObj Scm_MakeExtendedPair(ScmObj car, ScmObj cdr, ScmObj attrs)
789 {
790 return make_extended_pair(&mpair_desc, car, cdr, attrs);
791 }
792
793 /* Returns NULL if p isn't an extended pair. */
Scm__GetExtendedPairDescriptor(ScmObj p)794 ScmExtendedPairDescriptor *Scm__GetExtendedPairDescriptor(ScmObj p)
795 {
796 if (!SCM_EXTENDED_PAIR_P(p)) return NULL;
797 ScmRealExtendedPair *z = (ScmRealExtendedPair*)(((ScmObj*)p) - 1);
798 SCM_ASSERT((z->hiddenTag&0x7) == 0x7);
799 return (ScmExtendedPairDescriptor *)(z->hiddenTag-7);
800 }
801
Scm_PairAttr(ScmPair * pair)802 ScmObj Scm_PairAttr(ScmPair *pair)
803 {
804 if (SCM_EXTENDED_PAIR_P(pair)) {
805 return SCM_EXTENDED_PAIR(pair)->attributes;
806 } else {
807 return SCM_NIL;
808 }
809 }
810
811 /* The common scenario is to use ExtendedCons in place of Cons,
812 then add attributes later. So we provide this. */
Scm_ExtendedCons(ScmObj car,ScmObj cdr)813 ScmObj Scm_ExtendedCons(ScmObj car, ScmObj cdr)
814 {
815 return Scm_MakeExtendedPair(car, cdr, SCM_NIL);
816 }
817
Scm_PairAttrGet(ScmPair * pair,ScmObj key,ScmObj fallback)818 ScmObj Scm_PairAttrGet(ScmPair *pair, ScmObj key, ScmObj fallback)
819 {
820 if (!SCM_EXTENDED_PAIR_P(pair)) {
821 goto fallback;
822 }
823
824 ScmObj p = Scm_Assq(key, SCM_EXTENDED_PAIR(pair)->attributes);
825 if (SCM_PAIRP(p)) return SCM_CDR(p);
826 fallback:
827 if (fallback == SCM_UNBOUND)
828 Scm_Error("No value associated with key %S in pair attributes of %S",
829 key, SCM_OBJ(pair));
830 return fallback;
831 }
832
Scm_PairAttrSet(ScmPair * pair,ScmObj key,ScmObj value)833 ScmObj Scm_PairAttrSet(ScmPair *pair, ScmObj key, ScmObj value)
834 {
835 if (!SCM_EXTENDED_PAIR_P(pair)) {
836 Scm_Error("Cannot set pair attribute (%S) to non-extended pair: %S",
837 key, SCM_OBJ(pair));
838 }
839
840 ScmObj p = Scm_Assq(key, SCM_EXTENDED_PAIR(pair)->attributes);
841 if (SCM_PAIRP(p)) SCM_SET_CDR_UNCHECKED(p, value);
842 else SCM_EXTENDED_PAIR(pair)->attributes
843 = Scm_Acons(key, value, SCM_EXTENDED_PAIR(pair)->attributes);
844 return SCM_UNDEFINED;
845 }
846
847 /*
848 * Immutable pairs
849 */
850
851 /* not cheap. usually you don't want to check this and let it catched
852 in set-car!/set-cdr!. */
Scm_ImmutablePairP(ScmObj obj)853 int Scm_ImmutablePairP(ScmObj obj)
854 {
855 if (!SCM_EXTENDED_PAIR_P(obj)) return FALSE;
856 ScmExtendedPairDescriptor *d = Scm__GetExtendedPairDescriptor(obj);
857 return d->flags & SCM_PAIR_IMMUTABLE;
858 }
859
860 static ScmExtendedPairDescriptor ipair_desc = {
861 NULL, /* will be SCM_CLASS_PAIR. see above. */
862 SCM_PAIR_IMMUTABLE,
863 NULL,
864 NULL
865 };
866
Scm_MakeImmutablePair(ScmObj car,ScmObj cdr)867 ScmObj Scm_MakeImmutablePair(ScmObj car, ScmObj cdr)
868 {
869 return make_extended_pair(&ipair_desc, car, cdr, SCM_NIL);
870 }
871
872
Scm__InitList()873 void Scm__InitList()
874 {
875 mpair_desc.klass = SCM_CLASS_PAIR;
876 ipair_desc.klass = SCM_CLASS_PAIR;
877 }
878
879 /* Temporary - Check if normal pairs are all aligned with 2-word boundary */
880 #if GAUCHE_CHECK_PAIR_ALIGNMENT
Scm_CheckingPairP(ScmObj obj)881 int Scm_CheckingPairP(ScmObj obj)
882 {
883 if (SCM_HPTRP(obj)&&(SCM_HTAG(obj)!=7||Scm_PairP(SCM_OBJ(obj)))) {
884 if (SCM_WORD(obj) & SIZEOF_LONG) {
885 if ((SCM_WORD((ScmObj*)obj - 1) & 7) != 7) {
886 fprintf(stderr, "Unaligned pair %p\n", obj);
887 }
888 }
889 return TRUE;
890 }
891 return FALSE;
892 }
893 #endif /*GAUCHE_CHECK_PAIR_ALIGNMENT*/
894
895