root/src/list.c

/* [<][>][^][v][top][bottom][index][help] */

DEFINITIONS

This source file includes following definitions.
  1. Scm_Cons
  2. Scm_Acons
  3. Scm_List
  4. Scm_Conses
  5. Scm_VaList
  6. Scm_VaCons
  7. Scm_ArrayToList
  8. Scm_ListToArray
  9. CXR
  10. Scm_CopyList
  11. Scm_MakeList
  12. Scm_Append2X
  13. Scm_Append2
  14. Scm_Append
  15. Scm_Reverse
  16. Scm_ReverseX
  17. Scm_ListTail
  18. Scm_ListRef
  19. Scm_LastPair
  20. Scm_Memq
  21. Scm_Memv
  22. Scm_Member
  23. Scm_Delete
  24. Scm_DeleteX
  25. Scm_Assq
  26. Scm_Assv
  27. Scm_Assoc
  28. Scm_AssocDelete
  29. Scm_AssocDeleteX
  30. Scm_DeleteDuplicates
  31. Scm_DeleteDuplicatesX
  32. Scm_MonotonicMerge
  33. Scm_PairAttr
  34. Scm_ExtendedCons
  35. Scm_PairAttrGet
  36. 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 

/* [<][>][^][v][top][bottom][index][help] */