/* [<][>][^][v][top][bottom][index][help] */
DEFINITIONS
This source file includes following definitions.
- Scm_Cons
- Scm_Acons
- Scm_List
- Scm_Conses
- Scm_VaList
- Scm_VaCons
- Scm_ArrayToList
- Scm_ListToArray
- CXR
- Scm_CopyList
- Scm_MakeList
- Scm_Append2X
- Scm_Append2
- Scm_Append
- Scm_Reverse
- Scm_ReverseX
- Scm_ListTail
- Scm_ListRef
- Scm_LastPair
- Scm_Memq
- Scm_Memv
- Scm_Member
- Scm_Delete
- Scm_DeleteX
- Scm_Assq
- Scm_Assv
- Scm_Assoc
- Scm_AssocDelete
- Scm_AssocDeleteX
- Scm_DeleteDuplicates
- Scm_DeleteDuplicatesX
- Scm_MonotonicMerge
- Scm_PairAttr
- Scm_ExtendedCons
- Scm_PairAttrGet
- Scm_PairAttrSet
1 /*
2 * list.c - List related functions
3 *
4 * Copyright (c) 2000-2005 Shiro Kawai, 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 *
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 * $Id: list.c,v 1.46 2005/10/04 10:52:19 shirok Exp $
34 */
35
36 #define LIBGAUCHE_BODY
37 #include "gauche.h"
38 #include "gauche/memory.h"
39
40 /*
41 * Classes
42 */
43
44 static ScmClass *list_cpl[] = {
45 SCM_CLASS_STATIC_PTR(Scm_ListClass),
46 SCM_CLASS_STATIC_PTR(Scm_SequenceClass),
47 SCM_CLASS_STATIC_PTR(Scm_CollectionClass),
48 SCM_CLASS_STATIC_PTR(Scm_TopClass),
49 NULL
50 };
51
52 SCM_DEFINE_BUILTIN_CLASS(Scm_ListClass, NULL, NULL, NULL, NULL, list_cpl+1);
53 SCM_DEFINE_BUILTIN_CLASS(Scm_PairClass, NULL, NULL, NULL, NULL, list_cpl);
54 SCM_DEFINE_BUILTIN_CLASS(Scm_NullClass, NULL, NULL, NULL, NULL, list_cpl);
55
56 /*
57 * CONSTRUCTOR
58 */
59
60 ScmObj Scm_Cons(ScmObj car, ScmObj cdr)
61 {
62 ScmPair *z;
63 SCM_MALLOC_WORDS(z, sizeof(ScmPair)/sizeof(GC_word), ScmPair*);
64 SCM_SET_CAR(z, car);
65 SCM_SET_CDR(z, cdr);
66 return SCM_OBJ(z);
67 }
68
69 ScmObj Scm_Acons(ScmObj caar, ScmObj cdar, ScmObj cdr)
70 {
71 ScmPair *y, *z;
72 SCM_MALLOC_WORDS(y, sizeof(ScmPair)/sizeof(GC_word), ScmPair*);
73 SCM_MALLOC_WORDS(z, sizeof(ScmPair)/sizeof(GC_word), ScmPair*);
74 SCM_SET_CAR(y, caar);
75 SCM_SET_CDR(y, cdar);
76 SCM_SET_CAR(z, SCM_OBJ(y));
77 SCM_SET_CDR(z, cdr);
78 return SCM_OBJ(z);
79 }
80
81 ScmObj Scm_List(ScmObj elt, ...)
82 {
83 va_list pvar;
84 ScmObj cdr;
85
86 if (elt == NULL) return SCM_NIL;
87
88 va_start(pvar, elt);
89 cdr = Scm_VaList(pvar);
90 va_end(pvar);
91 return Scm_Cons(elt, cdr);
92 }
93
94
95 ScmObj Scm_Conses(ScmObj elt, ...)
96 {
97 va_list pvar;
98 ScmObj cdr;
99
100 if (elt == NULL) return SCM_NIL;
101
102 va_start(pvar, elt);
103 cdr = Scm_VaCons(pvar);
104 va_end(pvar);
105 if (cdr == NULL) return elt;
106 else return Scm_Cons(elt, cdr);
107 }
108
109
110 ScmObj Scm_VaList(va_list pvar)
111 {
112 ScmObj start = SCM_NIL, cp = SCM_NIL, obj;
113
114 for (obj = va_arg(pvar, ScmObj);
115 obj != NULL;
116 obj = va_arg(pvar, ScmObj))
117 {
118 if (SCM_NULLP(start)) {
119 start = SCM_OBJ(SCM_NEW(ScmPair));
120 /*SCM_SET_CLASS(start, SCM_CLASS_PAIR);*/
121 SCM_SET_CAR(start, obj);
122 SCM_SET_CDR(start, SCM_NIL);
123 cp = start;
124 } else {
125 ScmObj item;
126 item = SCM_OBJ(SCM_NEW(ScmPair));
127 /*SCM_SET_CLASS(item, SCM_CLASS_PAIR);*/
128 SCM_SET_CDR(cp, item);
129 SCM_SET_CAR(item, obj);
130 SCM_SET_CDR(item, SCM_NIL);
131 cp = item;
132 }
133 }
134 return start;
135 }
136
137
138 ScmObj Scm_VaCons(va_list pvar)
139 {
140 Scm_Panic("Scm_VaCons: not implemented");
141 return SCM_UNDEFINED;
142 }
143
144 ScmObj Scm_ArrayToList(ScmObj *elts, int nelts)
145 {
146 ScmObj h = SCM_NIL, t = SCM_NIL;
147 if (elts) {
148 int i;
149 for (i=0; i<nelts; i++) {
150 SCM_APPEND1(h, t, *elts++);
151 }
152 }
153 return h;
154 }
155
156 ScmObj *Scm_ListToArray(ScmObj list, int *nelts, ScmObj *store, int alloc)
157 {
158 ScmObj *array, lp;
159 int len = Scm_Length(list), i;
160 if (len < 0) Scm_Error("proper list required, but got %S", list);
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 for (i=0, lp=list; i<len; i++, lp=SCM_CDR(lp)) {
173 array[i] = SCM_CAR(lp);
174 }
175 *nelts = len;
176 return array;
177 }
178
179 /* cXr stuff */
180
181 #define CXR(cname, sname, body) \
182 ScmObj cname (ScmObj obj) \
183 { \
184 ScmObj obj2 = obj; \
185 body \
186 return obj2; \
187 }
188
189 #define A \
190 if (!SCM_PAIRP(obj2)) Scm_Error("bad object: %S", obj); \
191 obj2 = SCM_CAR(obj2);
192
193 #define D \
194 if (!SCM_PAIRP(obj2)) Scm_Error("bad object: %S", obj); \
195 obj2 = SCM_CDR(obj2);
196
197 CXR(Scm_Car, "car", A)
198 CXR(Scm_Cdr, "cdr", D)
199 CXR(Scm_Caar, "caar", A A)
200 CXR(Scm_Cadr, "cadr", D A)
201 CXR(Scm_Cdar, "cdar", A D)
202 CXR(Scm_Cddr, "cddr", D D)
203
204 /*
205 * List manipulate routines:
206 */
207
208 /* Scm_Length
209 return length of list in C integer.
210 If the argument is a dotted list, return -1.
211 If the argument is a circular list, return -2. */
212
213 int Scm_Length(ScmObj obj)
214 {
215 ScmObj slow = obj;
216 int len = 0;
217
218 for (;;) {
219 if (SCM_NULLP(obj)) break;
220 if (!SCM_PAIRP(obj)) return SCM_LIST_DOTTED;
221
222 obj = SCM_CDR(obj);
223 len++;
224 if (SCM_NULLP(obj)) break;
225 if (!SCM_PAIRP(obj)) return SCM_LIST_DOTTED;
226
227 obj = SCM_CDR(obj);
228 slow = SCM_CDR(slow);
229 if (obj == slow) return SCM_LIST_CIRCULAR;
230 len++;
231 }
232 return len;
233 }
234
235 /* Scm_CopyList(list)
236 * Copy toplevel list LIST. LIST can be improper.
237 * If LIST is not a pair, return LIST itself.
238 */
239
240 ScmObj Scm_CopyList(ScmObj list)
241 {
242 ScmObj start = SCM_NIL, last = SCM_NIL;
243
244 if (!SCM_PAIRP(list)) return list;
245
246 SCM_FOR_EACH(list, list) {
247 SCM_APPEND1(start, last, SCM_CAR(list));
248 }
249 if (!SCM_NULLP(list)) SCM_SET_CDR(last, list);
250 return start;
251 }
252
253 /* Scm_MakeList(len, fill)
254 * Make a list of specified length.
255 * Note that <len> is C-integer.
256 */
257
258 ScmObj Scm_MakeList(int len, ScmObj fill)
259 {
260 ScmObj start = SCM_NIL, last = SCM_NIL;
261 if (len < 0) {
262 Scm_Error("make-list: negative length given: %d", len);
263 }
264 while (len--) {
265 SCM_APPEND1(start, last, fill);
266 }
267 return start;
268 }
269
270
271 /* Scm_Append2X(list, obj)
272 * Replace cdr of last pair of LIST for OBJ.
273 * If LIST is not a pair, return OBJ.
274 */
275
276 ScmObj Scm_Append2X(ScmObj list, ScmObj obj)
277 {
278 ScmObj cp;
279 SCM_FOR_EACH(cp, list) {
280 if (SCM_NULLP(SCM_CDR(cp))) {
281 SCM_SET_CDR(cp, obj);
282 return list;
283 }
284 }
285 return obj;
286 }
287
288 /* Scm_Append2(list, obj)
289 * Copy LIST and append OBJ to it.
290 * If LIST is not a pair, return OBJ.
291 */
292
293 ScmObj Scm_Append2(ScmObj list, ScmObj obj)
294 {
295 ScmObj start = SCM_NIL, last = SCM_NIL;
296
297 if (!SCM_PAIRP(list)) return obj;
298
299 SCM_FOR_EACH(list, list) {
300 SCM_APPEND1(start, last, SCM_CAR(list));
301 }
302 SCM_SET_CDR(last, obj);
303
304 return start;
305 }
306
307 ScmObj Scm_Append(ScmObj args)
308 {
309 ScmObj start = SCM_NIL, last = SCM_NIL, cp;
310 SCM_FOR_EACH(cp, args) {
311 if (!SCM_PAIRP(SCM_CDR(cp))) {
312 if (SCM_NULLP(start)) return SCM_CAR(cp);
313 SCM_SET_CDR(last, SCM_CAR(cp));
314 break;
315 } else if (SCM_NULLP(SCM_CAR(cp))) {
316 continue;
317 } else if (!SCM_PAIRP(SCM_CAR(cp))) {
318 Scm_Error("pair required, but got %S", SCM_CAR(cp));
319 } else {
320 SCM_APPEND(start, last, Scm_CopyList(SCM_CAR(cp)));
321 }
322 }
323 return start;
324 }
325
326 /* Scm_Reverse(list)
327 * Reverse LIST. If LIST is not a pair, return LIST itself.
328 * If LIST is improper list, cdr of the last pair is ignored.
329 */
330
331 ScmObj Scm_Reverse(ScmObj list)
332 {
333 ScmObj cp, result;
334 ScmPair *p;
335
336 if (!SCM_PAIRP(list)) return list;
337
338 SCM_NEW_PAIR(p, SCM_NIL, SCM_NIL);
339 result = SCM_OBJ(p);
340 SCM_FOR_EACH(cp, list) {
341 SCM_SET_CAR(result, SCM_CAR(cp));
342 SCM_NEW_PAIR(p, SCM_NIL, result);
343 result = SCM_OBJ(p);
344 }
345 return SCM_CDR(result);
346 }
347
348
349 /* Scm_ReverseX(list)
350 * Return reversed list of LIST. Pairs in previous LIST is used to
351 * create new list. If LIST is not a pair, return LIST itself.
352 * If LIST is an improper list, cdr of the last cell is ignored.
353 */
354
355 ScmObj Scm_ReverseX(ScmObj list)
356 {
357 ScmObj first, next, result = SCM_NIL;
358 if (!SCM_PAIRP(list)) return list;
359 for (first = list; SCM_PAIRP(first); first = next) {
360 next = SCM_CDR(first);
361 SCM_SET_CDR(first, result);
362 result = first;
363 }
364 return result;
365 }
366
367 /* Scm_ListTail(list, i, fallback)
368 * Scm_ListRef(list, i, fallback)
369 * Note that i is C-INTEGER. If i is out of bound, signal error.
370 */
371
372 ScmObj Scm_ListTail(ScmObj list, int i, ScmObj fallback)
373 {
374 int cnt = i;
375 if (i < 0) goto err;
376 while (cnt-- > 0) {
377 if (!SCM_PAIRP(list)) goto err;
378 list = SCM_CDR(list);
379 }
380 return list;
381 err:
382 if (SCM_UNBOUNDP(fallback)) Scm_Error("argument out of range: %d", i);
383 return fallback;
384 }
385
386 ScmObj Scm_ListRef(ScmObj list, int i, ScmObj fallback)
387 {
388 int k;
389 if (i < 0) goto err;
390 for (k=0; k<i; k++) {
391 if (!SCM_PAIRP(list)) goto err;
392 list = SCM_CDR(list);
393 }
394 if (!SCM_PAIRP(list)) goto err;
395 return SCM_CAR(list);
396 err:
397 if (SCM_UNBOUNDP(fallback)) {
398 Scm_Error("argument out of range: %d", i);
399 }
400 return fallback;
401 }
402
403 /* Scm_LastPair(l)
404 * Return last pair of (maybe improper) list L.
405 * If L is not a pair, signal error.
406 */
407
408 ScmObj Scm_LastPair(ScmObj l)
409 {
410 ScmObj cp;
411
412 if (!SCM_PAIRP(l)) Scm_Error("pair required: %S", l);
413 SCM_FOR_EACH(cp, l) {
414 ScmObj cdr = SCM_CDR(cp);
415 if (!SCM_PAIRP(cdr)) return cp;
416 }
417 return SCM_UNDEFINED; /* NOTREACHED */
418 }
419
420 /* Scm_Memq(obj, list)
421 * Scm_Memv(obj, list)
422 * Scm_Member(obj, list)
423 * LIST must be a list. Return the first sublist whose car is obj.
424 * If obj doesn't occur in LIST, or LIST is not a pair, #f is returned.
425 */
426
427 ScmObj Scm_Memq(ScmObj obj, ScmObj list)
428 {
429 SCM_FOR_EACH(list, list) if (obj == SCM_CAR(list)) return list;
430 return SCM_FALSE;
431 }
432
433 ScmObj Scm_Memv(ScmObj obj, ScmObj list)
434 {
435 SCM_FOR_EACH(list, list) {
436 if (Scm_EqvP(obj, SCM_CAR(list))) return list;
437 }
438 return SCM_FALSE;
439 }
440
441 ScmObj Scm_Member(ScmObj obj, ScmObj list, int cmpmode)
442 {
443 SCM_FOR_EACH(list, list) {
444 if (Scm_EqualM(obj, SCM_CAR(list), cmpmode)) return list;
445 }
446 return SCM_FALSE;
447 }
448
449 /* delete. */
450 ScmObj Scm_Delete(ScmObj obj, ScmObj list, int cmpmode)
451 {
452 ScmObj start = SCM_NIL, last = SCM_NIL, cp, prev = list;
453
454 if (SCM_NULLP(list)) return SCM_NIL;
455 SCM_FOR_EACH(cp, list) {
456 if (Scm_EqualM(obj, SCM_CAR(cp), cmpmode)) {
457 for (; prev != cp; prev = SCM_CDR(prev))
458 SCM_APPEND1(start, last, SCM_CAR(prev));
459 prev = SCM_CDR(cp);
460 }
461 }
462 if (list == prev) return list;
463 if (SCM_NULLP(start)) return prev;
464 if (SCM_PAIRP(prev)) SCM_SET_CDR(last, prev);
465 return start;
466 }
467
468 ScmObj Scm_DeleteX(ScmObj obj, ScmObj list, int cmpmode)
469 {
470 ScmObj cp, prev = SCM_NIL;
471 SCM_FOR_EACH(cp, list) {
472 if (Scm_EqualM(obj, SCM_CAR(cp), cmpmode)) {
473 if (SCM_NULLP(prev)) {
474 list = SCM_CDR(cp);
475 } else {
476 SCM_SET_CDR(prev, SCM_CDR(cp));
477 }
478 } else {
479 prev = cp;
480 }
481 }
482 return list;
483 }
484
485
486 /*
487 * assq, assv, assoc
488 * ALIST must be a list of pairs. Return the first pair whose car
489 * is obj. If ALIST contains non pair, it's silently ignored.
490 */
491
492 ScmObj Scm_Assq(ScmObj obj, ScmObj alist)
493 {
494 ScmObj cp;
495 if (!SCM_LISTP(alist)) Scm_Error("assq: list required, but got %S", alist);
496 SCM_FOR_EACH(cp,alist) {
497 ScmObj entry = SCM_CAR(cp);
498 if (!SCM_PAIRP(entry)) continue;
499 if (obj == SCM_CAR(entry)) return entry;
500 }
501 return SCM_FALSE;
502 }
503
504 ScmObj Scm_Assv(ScmObj obj, ScmObj alist)
505 {
506 ScmObj cp;
507 if (!SCM_LISTP(alist)) Scm_Error("assv: list required, but got %S", alist);
508 SCM_FOR_EACH(cp,alist) {
509 ScmObj entry = SCM_CAR(cp);
510 if (!SCM_PAIRP(entry)) continue;
511 if (Scm_EqvP(obj, SCM_CAR(entry))) return entry;
512 }
513 return SCM_FALSE;
514 }
515
516 ScmObj Scm_Assoc(ScmObj obj, ScmObj alist, int cmpmode)
517 {
518 ScmObj cp;
519 if (!SCM_LISTP(alist)) Scm_Error("assoc: list required, but got %S", alist);
520 SCM_FOR_EACH(cp,alist) {
521 ScmObj entry = SCM_CAR(cp);
522 if (!SCM_PAIRP(entry)) continue;
523 if (Scm_EqualM(obj, SCM_CAR(entry), cmpmode)) return entry;
524 }
525 return SCM_FALSE;
526 }
527
528 /* Assoc-delete */
529 ScmObj Scm_AssocDelete(ScmObj elt, ScmObj alist, int cmpmode)
530 {
531 ScmObj start = SCM_NIL, last = SCM_NIL, cp, p, prev = alist;
532 if (!SCM_LISTP(alist)) {
533 Scm_Error("assoc-delete: list required, but got %S", alist);
534 }
535 if (SCM_NULLP(alist)) return SCM_NIL;
536
537 SCM_FOR_EACH(cp, alist) {
538 p = SCM_CAR(cp);
539 if (SCM_PAIRP(p)) {
540 if (Scm_EqualM(elt, SCM_CAR(p), cmpmode)) {
541 for (; prev != cp; prev = SCM_CDR(prev))
542 SCM_APPEND1(start, last, SCM_CAR(prev));
543 prev = SCM_CDR(cp);
544 }
545 }
546 }
547 if (alist == prev) return alist;
548 if (SCM_NULLP(start)) return prev;
549 if (SCM_PAIRP(prev)) SCM_SET_CDR(last, prev);
550 return start;
551 }
552
553 ScmObj Scm_AssocDeleteX(ScmObj elt, ScmObj alist, int cmpmode)
554 {
555 ScmObj cp, prev = SCM_NIL;
556 if (!SCM_LISTP(alist)) {
557 Scm_Error("assoc-delete!: list required, but got %S", alist);
558 }
559 SCM_FOR_EACH(cp, alist) {
560 ScmObj e = SCM_CAR(cp);
561 if (SCM_PAIRP(e)) {
562 if (Scm_EqualM(elt, SCM_CAR(e), cmpmode)) {
563 if (SCM_NULLP(prev)) {
564 alist = SCM_CDR(cp);
565 continue;
566 } else {
567 SCM_SET_CDR(prev, SCM_CDR(cp));
568 }
569 }
570 }
571 prev = cp;
572 }
573 return alist;
574 }
575
576 /* DeleteDuplicates. preserve the order of original list. N^2 algorithm */
577
578 ScmObj Scm_DeleteDuplicates(ScmObj list, int cmpmode)
579 {
580 ScmObj result = SCM_NIL, tail = SCM_NIL, lp;
581 SCM_FOR_EACH(lp, list) {
582 if (SCM_FALSEP(Scm_Member(SCM_CAR(lp), result, cmpmode))) {
583 SCM_APPEND1(result, tail, SCM_CAR(lp));
584 }
585 }
586 if (!SCM_NULLP(lp)) SCM_SET_CDR(lp, tail);
587 return result;
588 }
589
590 ScmObj Scm_DeleteDuplicatesX(ScmObj list, int cmpmode)
591 {
592 ScmObj lp;
593
594 SCM_FOR_EACH(lp, list) {
595 ScmObj obj = SCM_CAR(lp);
596 ScmObj tail = Scm_DeleteX(obj, SCM_CDR(lp), cmpmode);
597 if (SCM_CDR(lp) != tail) SCM_SET_CDR(lp, tail);
598 }
599 return list;
600 }
601
602 /*
603 * Monotonic Merge
604 *
605 * Merge lists, keeping the order of elements (left to right) in each
606 * list. If there's more than one way to order an element, choose the
607 * first one appears in the given list of lists.
608 * Returns SCM_FALSE if the lists are inconsistent to be ordered
609 * in the way.
610 *
611 * START is an item of the starting point. It is inserted into the result
612 * first. SEQUENCES is a list of lists describing the order of preference.
613 *
614 * The algorithm is used in C3 linearization of class precedence
615 * calculation, described in the paper
616 * http://www.webcom.com/~haahr/dylan/linearization-oopsla96.html.
617 * Since the algorithm is generally useful, I implement the core routine
618 * of the algorithm here.
619 */
620
621 ScmObj Scm_MonotonicMerge(ScmObj start, ScmObj sequences)
622 {
623 ScmObj result = Scm_Cons(start, SCM_NIL), next, h;
624 ScmObj *seqv, *sp, *tp;
625 int nseqs = Scm_Length(sequences);
626
627 if (nseqs < 0) Scm_Error("bad list of sequences: %S", sequences);
628 seqv = SCM_NEW_ARRAY(ScmObj, nseqs);
629 for (sp=seqv; SCM_PAIRP(sequences); sp++, sequences=SCM_CDR(sequences)) {
630 *sp = SCM_CAR(sequences);
631 }
632
633 for (;;) {
634 /* have we consumed all the inputs? */
635 for (sp=seqv; sp<seqv+nseqs; sp++) {
636 if (!SCM_NULLP(*sp)) break;
637 }
638 if (sp == seqv+nseqs) return Scm_ReverseX(result);
639
640 /* select candidate */
641 next = SCM_FALSE;
642 for (sp = seqv; sp < seqv+nseqs; sp++) {
643 if (!SCM_PAIRP(*sp)) continue;
644 h = SCM_CAR(*sp);
645 for (tp = seqv; tp < seqv+nseqs; tp++) {
646 if (!SCM_PAIRP(*tp)) continue;
647 if (!SCM_FALSEP(Scm_Memq(h, SCM_CDR(*tp)))) {
648 break;
649 }
650 }
651 if (tp != seqv+nseqs) continue;
652 next = h;
653 break;
654 }
655
656 if (SCM_FALSEP(next)) return SCM_FALSE; /* inconsistent */
657
658 /* move the candidate to the result */
659 result = Scm_Cons(next, result);
660 for (sp = seqv; sp < seqv+nseqs; sp++) {
661 if (SCM_PAIRP(*sp) && SCM_EQ(next, SCM_CAR(*sp))) {
662 *sp = SCM_CDR(*sp);
663 }
664 }
665 }
666 /* NOTREACHED */
667 }
668
669 /*
670 * Pair attributes
671 */
672
673 ScmObj Scm_PairAttr(ScmPair *pair)
674 {
675 if (SCM_EXTENDED_PAIR_P(pair)) {
676 return SCM_EXTENDED_PAIR(pair)->attributes;
677 } else {
678 return SCM_NIL;
679 }
680 }
681
682 ScmObj Scm_ExtendedCons(ScmObj car, ScmObj cdr)
683 {
684 ScmExtendedPair *xp = SCM_NEW(ScmExtendedPair);
685 xp->car = car;
686 xp->cdr = cdr;
687 xp->attributes = SCM_NIL;
688 return SCM_OBJ(xp);
689 }
690
691 ScmObj Scm_PairAttrGet(ScmPair *pair, ScmObj key, ScmObj fallback)
692 {
693 ScmObj p;
694 if (!SCM_EXTENDED_PAIR_P(pair)) {
695 goto fallback;
696 }
697
698 p = Scm_Assq(key, SCM_EXTENDED_PAIR(pair)->attributes);
699 if (SCM_PAIRP(p)) return SCM_CDR(p);
700 fallback:
701 if (fallback == SCM_UNBOUND)
702 Scm_Error("No value associated with key %S in pair attributes of %S",
703 key, SCM_OBJ(pair));
704 return fallback;
705 }
706
707 ScmObj Scm_PairAttrSet(ScmPair *pair, ScmObj key, ScmObj value)
708 {
709 ScmObj p;
710 if (!SCM_EXTENDED_PAIR_P(pair)) {
711 Scm_Error("Cannot set pair attribute (%S) to non-extended pair: %S",
712 key, SCM_OBJ(pair));
713 }
714
715 p = Scm_Assq(key, SCM_EXTENDED_PAIR(pair)->attributes);
716 if (SCM_PAIRP(p)) SCM_SET_CDR(p, value);
717 else SCM_EXTENDED_PAIR(pair)->attributes
718 = Scm_Acons(key, value, SCM_EXTENDED_PAIR(pair)->attributes);
719 return SCM_UNDEFINED;
720 }
721
722