libguile/list.c

   1 /* Copyright (C) 1995,1996,1997,2000,2001,2003,2004,2008,2009,2010,2011
   2  * Free Software Foundation, Inc.
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public License
   6  * as published by the Free Software Foundation; either version 3 of
   7  * the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful, but
  10  * WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17  * 02110-1301 USA
  18  */
  19
  20
  21 \f
  22 #ifdef HAVE_CONFIG_H
  23 # include <config.h>
  24 #endif
  25
  26 #include "libguile/_scm.h"
  27 #include "libguile/eq.h"
  28
  29 #include "libguile/validate.h"
  30 #include "libguile/list.h"
  31 #include "libguile/eval.h"
  32
  33 #include <stdarg.h>
  34
  35 \f
  36 /* creating lists */
  37
  38 #define SCM_I_CONS(cell, x, y)                          \
  39   do {                                                  \
  40     cell = scm_cell (SCM_UNPACK (x), SCM_UNPACK (y));   \
  41   } while (0)
  42
  43 SCM
  44 scm_list_1 (SCM e1)
  45 {
  46   SCM c1;
  47   SCM_I_CONS (c1, e1, SCM_EOL);
  48   return c1;
  49 }
  50
  51 SCM
  52 scm_list_2 (SCM e1, SCM e2)
  53 {
  54   SCM c1, c2;
  55   SCM_I_CONS (c2, e2, SCM_EOL);
  56   SCM_I_CONS (c1, e1, c2);
  57   return c1;
  58 }
  59
  60 SCM
  61 scm_list_3 (SCM e1, SCM e2, SCM e3)
  62 {
  63   SCM c1, c2, c3;
  64   SCM_I_CONS (c3, e3, SCM_EOL);
  65   SCM_I_CONS (c2, e2, c3);
  66   SCM_I_CONS (c1, e1, c2);
  67   return c1;
  68 }
  69
  70 SCM
  71 scm_list_4 (SCM e1, SCM e2, SCM e3, SCM e4)
  72 {
  73   return scm_cons2 (e1, e2, scm_list_2 (e3, e4));
  74 }
  75
  76 SCM
  77 scm_list_5 (SCM e1, SCM e2, SCM e3, SCM e4, SCM e5)
  78 {
  79   return scm_cons2 (e1, e2, scm_list_3 (e3, e4, e5));
  80 }
  81
  82 SCM
  83 scm_list_n (SCM elt, ...)
  84 {
  85   va_list foo;
  86   SCM answer = SCM_EOL;
  87   SCM *pos = &answer;
  88
  89   va_start (foo, elt);
  90   while (! SCM_UNBNDP (elt))
  91     {
  92 #if (SCM_DEBUG_CELL_ACCESSES == 1)
  93       if (SCM_NIMP (elt))
  94         SCM_VALIDATE_CELL(elt, 0);
  95 #endif
  96       *pos = scm_cons (elt, SCM_EOL);
  97       pos = SCM_CDRLOC (*pos);
  98       elt = va_arg (foo, SCM);
  99     }
 100   va_end (foo);
 101   return answer;
 102 }
 103
 104
 105 SCM_DEFINE (scm_make_list, "make-list", 1, 1, 0,
 106             (SCM n, SCM init),
 107             "Create a list containing of @var{n} elements, where each\n"
 108             "element is initialized to @var{init}.  @var{init} defaults to\n"
 109             "the empty list @code{()} if not given.")
 110 #define FUNC_NAME s_scm_make_list
 111 {
 112   unsigned nn = scm_to_uint (n);
 113   unsigned i;
 114   SCM ret = SCM_EOL;
 115
 116   if (SCM_UNBNDP (init))
 117     init = SCM_EOL;
 118
 119   for (i = 0; i < nn; i++)
 120     ret = scm_cons (init, ret);
 121   return ret;
 122 }
 123 #undef FUNC_NAME
 124
 125
 126 SCM_DEFINE (scm_cons_star, "cons*", 1, 0, 1,
 127             (SCM arg, SCM rest),
 128             "Like @code{list}, but the last arg provides the tail of the\n"
 129             "constructed list, returning @code{(cons @var{arg1} (cons\n"
 130             "@var{arg2} (cons @dots{} @var{argn})))}.  Requires at least one\n"
 131             "argument.  If given one argument, that argument is returned as\n"
 132             "result.  This function is called @code{list*} in some other\n"
 133             "Schemes and in Common LISP.")
 134 #define FUNC_NAME s_scm_cons_star
 135 {
 136   SCM ret = SCM_EOL;
 137   SCM *p = &ret;
 138
 139   SCM_VALIDATE_REST_ARGUMENT (rest);
 140
 141   for ( ; scm_is_pair (rest); rest = SCM_CDR (rest))
 142     {
 143       *p = scm_cons (arg, SCM_EOL);
 144       p = SCM_CDRLOC (*p);
 145       arg = SCM_CAR (rest);
 146     }
 147
 148   *p = arg;
 149   return ret;
 150 }
 151 #undef FUNC_NAME
 152
 153
 154 \f
 155 /* general questions about lists --- null?, list?, length, etc.  */
 156
 157 SCM_DEFINE (scm_null_p, "null?", 1, 0, 0,
 158            (SCM x),
 159             "Return @code{#t} iff @var{x} is the empty list, else @code{#f}.")
 160 #define FUNC_NAME s_scm_null_p
 161 {
 162   return scm_from_bool (SCM_NULL_OR_NIL_P (x));
 163 }
 164 #undef FUNC_NAME
 165
 166
 167 SCM_DEFINE (scm_list_p, "list?", 1, 0, 0,
 168            (SCM x),
 169             "Return @code{#t} iff @var{x} is a proper list, else @code{#f}.")
 170 #define FUNC_NAME s_scm_list_p
 171 {
 172   return scm_from_bool (scm_ilength (x) >= 0);
 173 }
 174 #undef FUNC_NAME
 175
 176
 177 /* Return the length of SX, or -1 if it's not a proper list.
 178    This uses the "tortoise and hare" algorithm to detect "infinitely
 179    long" lists (i.e. lists with cycles in their cdrs), and returns -1
 180    if it does find one.  */
 181 long
 182 scm_ilength(SCM sx)
 183 {
 184   long i = 0;
 185   SCM tortoise = sx;
 186   SCM hare = sx;
 187
 188   do {
 189     if (SCM_NULL_OR_NIL_P(hare)) return i;
 190     if (!scm_is_pair (hare)) return -1;
 191     hare = SCM_CDR(hare);
 192     i++;
 193     if (SCM_NULL_OR_NIL_P(hare)) return i;
 194     if (!scm_is_pair (hare)) return -1;
 195     hare = SCM_CDR(hare);
 196     i++;
 197     /* For every two steps the hare takes, the tortoise takes one.  */
 198     tortoise = SCM_CDR(tortoise);
 199   }
 200   while (!scm_is_eq (hare, tortoise));
 201
 202   /* If the tortoise ever catches the hare, then the list must contain
 203      a cycle.  */
 204   return -1;
 205 }
 206
 207
 208 SCM_DEFINE (scm_length, "length", 1, 0, 0,
 209            (SCM lst),
 210             "Return the number of elements in list @var{lst}.")
 211 #define FUNC_NAME s_scm_length
 212 {
 213   long i;
 214   SCM_VALIDATE_LIST_COPYLEN (1, lst, i);
 215   return scm_from_long (i);
 216 }
 217 #undef FUNC_NAME
 218
 219
 220 \f
 221 /* appending lists */
 222
 223 SCM_DEFINE (scm_append, "append", 0, 0, 1,
 224             (SCM args),
 225             "Return a list consisting of the elements the lists passed as\n"
 226             "arguments.\n"
 227             "@lisp\n"
 228             "(append '(x) '(y))          @result{}  (x y)\n"
 229             "(append '(a) '(b c d))      @result{}  (a b c d)\n"
 230             "(append '(a (b)) '((c)))    @result{}  (a (b) (c))\n"
 231             "@end lisp\n"
 232             "The resulting list is always newly allocated, except that it\n"
 233             "shares structure with the last list argument.  The last\n"
 234             "argument may actually be any object; an improper list results\n"
 235             "if the last argument is not a proper list.\n"
 236             "@lisp\n"
 237             "(append '(a b) '(c . d))    @result{}  (a b c . d)\n"
 238             "(append '() 'a)             @result{}  a\n"
 239             "@end lisp")
 240 #define FUNC_NAME s_scm_append
 241 {
 242   SCM_VALIDATE_REST_ARGUMENT (args);
 243   if (scm_is_null (args)) {
 244     return SCM_EOL;
 245   } else {
 246     SCM res = SCM_EOL;
 247     SCM *lloc = &res;
 248     SCM arg = SCM_CAR (args);
 249     int argnum = 1;
 250     args = SCM_CDR (args);
 251     while (!scm_is_null (args)) {
 252       while (scm_is_pair (arg)) {
 253         *lloc = scm_cons (SCM_CAR (arg), SCM_EOL);
 254         lloc = SCM_CDRLOC (*lloc);
 255         arg = SCM_CDR (arg);
 256       }
 257       SCM_VALIDATE_NULL_OR_NIL (argnum, arg);
 258       arg = SCM_CAR (args);
 259       args = SCM_CDR (args);
 260       argnum++;
 261     };
 262     *lloc = arg;
 263     return res;
 264   }
 265 }
 266 #undef FUNC_NAME
 267
 268
 269 SCM_DEFINE (scm_append_x, "append!", 0, 0, 1,
 270             (SCM lists),
 271             "A destructive version of @code{append} (@pxref{Pairs and\n"
 272             "Lists,,,r5rs, The Revised^5 Report on Scheme}).  The cdr field\n"
 273             "of each list's final pair is changed to point to the head of\n"
 274             "the next list, so no consing is performed.  Return\n"
 275             "the mutated list.")
 276 #define FUNC_NAME s_scm_append_x
 277 {
 278   SCM ret, *loc;
 279   SCM_VALIDATE_REST_ARGUMENT (lists);
 280
 281   if (scm_is_null (lists))
 282     return SCM_EOL;
 283
 284   loc = &ret;
 285   for (;;)
 286     {
 287       SCM arg = SCM_CAR (lists);
 288       *loc = arg;
 289
 290       lists = SCM_CDR (lists);
 291       if (scm_is_null (lists))
 292         return ret;
 293
 294       if (!SCM_NULL_OR_NIL_P (arg))
 295         {
 296           SCM_VALIDATE_CONS (SCM_ARG1, arg);
 297           loc = SCM_CDRLOC (scm_last_pair (arg));
 298         }
 299     }
 300 }
 301 #undef FUNC_NAME
 302
 303
 304 SCM_DEFINE (scm_last_pair, "last-pair", 1, 0, 0,
 305            (SCM lst),
 306             "Return the last pair in @var{lst}, signalling an error if\n"
 307             "@var{lst} is circular.")
 308 #define FUNC_NAME s_scm_last_pair
 309 {
 310   SCM tortoise = lst;
 311   SCM hare = lst;
 312
 313   if (SCM_NULL_OR_NIL_P (lst))
 314     return lst;
 315
 316   SCM_VALIDATE_CONS (SCM_ARG1, lst);
 317   do {
 318     SCM ahead = SCM_CDR(hare);
 319     if (!scm_is_pair (ahead)) return hare;
 320     hare = ahead;
 321     ahead = SCM_CDR(hare);
 322     if (!scm_is_pair (ahead)) return hare;
 323     hare = ahead;
 324     tortoise = SCM_CDR(tortoise);
 325   }
 326   while (!scm_is_eq (hare, tortoise));
 327   SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst));
 328 }
 329 #undef FUNC_NAME
 330
 331 \f
 332 /* reversing lists */
 333
 334 SCM_DEFINE (scm_reverse, "reverse", 1, 0, 0,
 335             (SCM lst),
 336             "Return a new list that contains the elements of @var{lst} but\n"
 337             "in reverse order.")
 338 #define FUNC_NAME s_scm_reverse
 339 {
 340   SCM result = SCM_EOL;
 341   SCM tortoise = lst;
 342   SCM hare = lst;
 343
 344   do {
 345       if (SCM_NULL_OR_NIL_P(hare)) return result;
 346       SCM_ASSERT(scm_is_pair(hare), lst, 1, FUNC_NAME);
 347       result = scm_cons (SCM_CAR (hare), result);
 348       hare = SCM_CDR (hare);
 349       if (SCM_NULL_OR_NIL_P(hare)) return result;
 350       SCM_ASSERT(scm_is_pair(hare), lst, 1, FUNC_NAME);
 351       result = scm_cons (SCM_CAR (hare), result);
 352       hare = SCM_CDR (hare);
 353       tortoise = SCM_CDR (tortoise);
 354     }
 355   while (!scm_is_eq (hare, tortoise));
 356   SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst));
 357 }
 358 #undef FUNC_NAME
 359
 360 SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0,
 361             (SCM lst, SCM new_tail),
 362             "A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r5rs,\n"
 363             "The Revised^5 Report on Scheme}).  The cdr of each cell in @var{lst} is\n"
 364             "modified to point to the previous list element.  Return the\n"
 365             "reversed list.\n\n"
 366             "Caveat: because the list is modified in place, the tail of the original\n"
 367             "list now becomes its head, and the head of the original list now becomes\n"
 368             "the tail.  Therefore, the @var{lst} symbol to which the head of the\n"
 369             "original list was bound now points to the tail.  To ensure that the head\n"
 370             "of the modified list is not lost, it is wise to save the return value of\n"
 371             "@code{reverse!}")
 372 #define FUNC_NAME s_scm_reverse_x
 373 {
 374   SCM_VALIDATE_LIST (1, lst);
 375   if (SCM_UNBNDP (new_tail))
 376     new_tail = SCM_EOL;
 377   else
 378     SCM_VALIDATE_LIST (2, new_tail);
 379
 380   while (!SCM_NULL_OR_NIL_P (lst))
 381     {
 382       SCM old_tail = SCM_CDR (lst);
 383       SCM_SETCDR (lst, new_tail);
 384       new_tail = lst;
 385       lst = old_tail;
 386     }
 387   return new_tail;
 388 }
 389 #undef FUNC_NAME
 390
 391 \f
 392
 393 /* indexing lists by element number */
 394
 395 SCM_DEFINE (scm_list_ref, "list-ref", 2, 0, 0,
 396             (SCM list, SCM k),
 397             "Return the @var{k}th element from @var{list}.")
 398 #define FUNC_NAME s_scm_list_ref
 399 {
 400   SCM lst = list;
 401   unsigned long int i;
 402   i = scm_to_ulong (k);
 403   while (scm_is_pair (lst)) {
 404     if (i == 0)
 405       return SCM_CAR (lst);
 406     else {
 407       --i;
 408       lst = SCM_CDR (lst);
 409     }
 410   };
 411   if (SCM_NULL_OR_NIL_P (lst))
 412     SCM_OUT_OF_RANGE (2, k);
 413   else
 414     SCM_WRONG_TYPE_ARG (1, list);
 415 }
 416 #undef FUNC_NAME
 417
 418
 419 SCM_DEFINE (scm_list_set_x, "list-set!", 3, 0, 0,
 420             (SCM list, SCM k, SCM val),
 421             "Set the @var{k}th element of @var{list} to @var{val}.")
 422 #define FUNC_NAME s_scm_list_set_x
 423 {
 424   SCM lst = list;
 425   unsigned long int i = scm_to_ulong (k);
 426   while (scm_is_pair (lst)) {
 427     if (i == 0) {
 428       SCM_SETCAR (lst, val);
 429       return val;
 430     } else {
 431       --i;
 432       lst = SCM_CDR (lst);
 433     }
 434   };
 435   if (SCM_NULL_OR_NIL_P (lst))
 436     SCM_OUT_OF_RANGE (2, k);
 437   else
 438     SCM_WRONG_TYPE_ARG (1, list);
 439 }
 440 #undef FUNC_NAME
 441
 442
 443 SCM_REGISTER_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail);
 444
 445 SCM_DEFINE (scm_list_tail, "list-tail", 2, 0, 0,
 446            (SCM lst, SCM k),
 447             "@deffnx {Scheme Procedure} list-cdr-ref lst k\n"
 448             "Return the \"tail\" of @var{lst} beginning with its @var{k}th element.\n"
 449             "The first element of the list is considered to be element 0.\n\n"
 450             "@code{list-tail} and @code{list-cdr-ref} are identical.  It may help to\n"
 451             "think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list,\n"
 452             "or returning the results of cdring @var{k} times down @var{lst}.")
 453 #define FUNC_NAME s_scm_list_tail
 454 {
 455   size_t i = scm_to_size_t (k);
 456   while (i-- > 0) {
 457     SCM_VALIDATE_CONS (1, lst);
 458     lst = SCM_CDR(lst);
 459   }
 460   return lst;
 461 }
 462 #undef FUNC_NAME
 463
 464
 465 SCM_DEFINE (scm_list_cdr_set_x, "list-cdr-set!", 3, 0, 0,
 466            (SCM list, SCM k, SCM val),
 467             "Set the @var{k}th cdr of @var{list} to @var{val}.")
 468 #define FUNC_NAME s_scm_list_cdr_set_x
 469 {
 470   SCM lst = list;
 471   size_t i = scm_to_size_t (k);
 472   while (scm_is_pair (lst)) {
 473     if (i == 0) {
 474       SCM_SETCDR (lst, val);
 475       return val;
 476     } else {
 477       --i;
 478       lst = SCM_CDR (lst);
 479     }
 480   };
 481   if (SCM_NULL_OR_NIL_P (lst))
 482     SCM_OUT_OF_RANGE (2, k);
 483   else
 484     SCM_WRONG_TYPE_ARG (1, list);
 485 }
 486 #undef FUNC_NAME
 487
 488
 489 \f
 490 /* copying lists, perhaps partially */
 491
 492 SCM_DEFINE (scm_list_head, "list-head", 2, 0, 0,
 493            (SCM lst, SCM k),
 494             "Copy the first @var{k} elements from @var{lst} into a new list, and\n"
 495             "return it.")
 496 #define FUNC_NAME s_scm_list_head
 497 {
 498   SCM answer;
 499   SCM * pos;
 500   size_t i = scm_to_size_t (k);
 501
 502   answer = SCM_EOL;
 503   pos = &answer;
 504   while (i-- > 0)
 505     {
 506       SCM_VALIDATE_CONS (1, lst);
 507       *pos = scm_cons (SCM_CAR (lst), SCM_EOL);
 508       pos = SCM_CDRLOC (*pos);
 509       lst = SCM_CDR(lst);
 510     }
 511   return answer;
 512 }
 513 #undef FUNC_NAME
 514
 515
 516 /* Copy a list which is known to be finite.  The last pair may or may not have
 517  * a '() in its cdr.  That is, improper lists are accepted.  */
 518 SCM
 519 scm_i_finite_list_copy (SCM list)
 520 {
 521   if (!scm_is_pair (list))
 522     {
 523       return list;
 524     }
 525   else
 526     {
 527       SCM tail;
 528       const SCM result = tail = scm_list_1 (SCM_CAR (list));
 529       list = SCM_CDR (list);
 530       while (scm_is_pair (list))
 531         {
 532           const SCM new_tail = scm_list_1 (SCM_CAR (list));
 533           SCM_SETCDR (tail, new_tail);
 534           tail = new_tail;
 535           list = SCM_CDR (list);
 536         }
 537       SCM_SETCDR (tail, list);
 538
 539       return result;
 540     }
 541 }
 542
 543
 544 SCM_DEFINE (scm_list_copy, "list-copy", 1, 0, 0,
 545             (SCM lst),
 546             "Return a (newly-created) copy of @var{lst}.")
 547 #define FUNC_NAME s_scm_list_copy
 548 {
 549   SCM newlst;
 550   SCM * fill_here;
 551   SCM from_here;
 552
 553   SCM_VALIDATE_LIST (1, lst);
 554
 555   newlst = SCM_EOL;
 556   fill_here = &newlst;
 557   from_here = lst;
 558
 559   while (scm_is_pair (from_here))
 560     {
 561       SCM c;
 562       c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here));
 563       *fill_here = c;
 564       fill_here = SCM_CDRLOC (c);
 565       from_here = SCM_CDR (from_here);
 566     }
 567   return newlst;
 568 }
 569 #undef FUNC_NAME
 570
 571
 572 SCM_PROC (s_list, "list", 0, 0, 1, scm_list_copy);
 573 SCM_SNARF_DOCS (primitive, scm_list_copy, "list", (SCM objs), 0, 0, 1,
 574                 "Return a list containing @var{objs}, the arguments to\n"
 575                 "@code{list}.")
 576
 577 /* This used to be the code for "list", but it's wrong when used via apply
 578    (it should copy the list).  It seems pretty unlikely anyone would have
 579    been using this from C code, since it's a no-op, but keep it for strict
 580    binary compatibility.  */
 581 SCM
 582 scm_list (SCM objs)
 583 {
 584   return objs;
 585 }
 586
 587
 588 \f
 589 /* membership tests (memq, memv, etc.) */
 590
 591 /* The function scm_c_memq returns the first sublist of list whose car is
 592  * 'eq?' obj, where the sublists of list are the non-empty lists returned by
 593  * (list-tail list k) for k less than the length of list.  If obj does not
 594  * occur in list, then #f (not the empty list) is returned.
 595  * List must be a proper list, otherwise scm_c_memq may crash or loop
 596  * endlessly.
 597  */
 598 SCM
 599 scm_c_memq (SCM obj, SCM list)
 600 {
 601   for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR (list))
 602     {
 603       if (scm_is_eq (SCM_CAR (list), obj))
 604         return list;
 605     }
 606   return SCM_BOOL_F;
 607 }
 608
 609
 610 SCM_DEFINE (scm_memq, "memq", 2, 0, 0,
 611            (SCM x, SCM lst),
 612             "Return the first sublist of @var{lst} whose car is @code{eq?}\n"
 613             "to @var{x} where the sublists of @var{lst} are the non-empty\n"
 614             "lists returned by @code{(list-tail @var{lst} @var{k})} for\n"
 615             "@var{k} less than the length of @var{lst}.  If @var{x} does not\n"
 616             "occur in @var{lst}, then @code{#f} (not the empty list) is\n"
 617             "returned.")
 618 #define FUNC_NAME s_scm_memq
 619 {
 620   SCM hare = lst, tortoise = lst;
 621
 622   while (scm_is_pair (hare))
 623     {
 624       if (scm_is_eq (SCM_CAR (hare), x))
 625         return hare;
 626       else
 627         hare = SCM_CDR (hare);
 628
 629       if (!scm_is_pair (hare))
 630         break;
 631
 632       if (scm_is_eq (SCM_CAR (hare), x))
 633         return hare;
 634       else
 635         hare = SCM_CDR (hare);
 636
 637       tortoise = SCM_CDR (tortoise);
 638       if (SCM_UNLIKELY (scm_is_eq (hare, tortoise)))
 639         break;
 640     }
 641
 642   if (SCM_LIKELY (scm_is_null (hare)))
 643     return SCM_BOOL_F;
 644   else
 645     scm_wrong_type_arg_msg (FUNC_NAME, 2, lst, "list");
 646 }
 647 #undef FUNC_NAME
 648
 649
 650 SCM_DEFINE (scm_memv, "memv", 2, 0, 0,
 651            (SCM x, SCM lst),
 652             "Return the first sublist of @var{lst} whose car is @code{eqv?}\n"
 653             "to @var{x} where the sublists of @var{lst} are the non-empty\n"
 654             "lists returned by @code{(list-tail @var{lst} @var{k})} for\n"
 655             "@var{k} less than the length of @var{lst}.  If @var{x} does not\n"
 656             "occur in @var{lst}, then @code{#f} (not the empty list) is\n"
 657             "returned.")
 658 #define FUNC_NAME s_scm_memv
 659 {
 660   SCM hare = lst, tortoise = lst;
 661
 662   while (scm_is_pair (hare))
 663     {
 664       if (scm_is_true (scm_eqv_p (SCM_CAR (hare), x)))
 665         return hare;
 666       else
 667         hare = SCM_CDR (hare);
 668
 669       if (!scm_is_pair (hare))
 670         break;
 671
 672       if (scm_is_true (scm_eqv_p (SCM_CAR (hare), x)))
 673         return hare;
 674       else
 675         hare = SCM_CDR (hare);
 676
 677       tortoise = SCM_CDR (tortoise);
 678       if (SCM_UNLIKELY (scm_is_eq (hare, tortoise)))
 679         break;
 680     }
 681
 682   if (SCM_LIKELY (scm_is_null (hare)))
 683     return SCM_BOOL_F;
 684   else
 685     scm_wrong_type_arg_msg (FUNC_NAME, 2, lst, "list");
 686 }
 687 #undef FUNC_NAME
 688
 689
 690 SCM_DEFINE (scm_member, "member", 2, 0, 0,
 691            (SCM x, SCM lst),
 692             "Return the first sublist of @var{lst} whose car is\n"
 693             "@code{equal?} to @var{x} where the sublists of @var{lst} are\n"
 694             "the non-empty lists returned by @code{(list-tail @var{lst}\n"
 695             "@var{k})} for @var{k} less than the length of @var{lst}.  If\n"
 696             "@var{x} does not occur in @var{lst}, then @code{#f} (not the\n"
 697             "empty list) is returned.")
 698 #define FUNC_NAME s_scm_member
 699 {
 700   SCM_VALIDATE_LIST (2, lst);
 701   for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
 702     {
 703       if (! scm_is_false (scm_equal_p (SCM_CAR (lst), x)))
 704         return lst;
 705     }
 706   return SCM_BOOL_F;
 707 }
 708 #undef FUNC_NAME
 709
 710 \f
 711 /* deleting elements from a list (delq, etc.) */
 712
 713 SCM_DEFINE (scm_delq_x, "delq!", 2, 0, 0,
 714            (SCM item, SCM lst),
 715             "@deffnx {Scheme Procedure} delv! item lst\n"
 716             "@deffnx {Scheme Procedure} delete! item lst\n"
 717             "These procedures are destructive versions of @code{delq}, @code{delv}\n"
 718             "and @code{delete}: they modify the existing @var{lst}\n"
 719             "rather than creating a new list.  Caveat evaluator: Like other\n"
 720             "destructive list functions, these functions cannot modify the binding of\n"
 721             "@var{lst}, and so cannot be used to delete the first element of\n"
 722             "@var{lst} destructively.")
 723 #define FUNC_NAME s_scm_delq_x
 724 {
 725   SCM walk;
 726   SCM *prev;
 727
 728   for (prev = &lst, walk = lst;
 729        scm_is_pair (walk);
 730        walk = SCM_CDR (walk))
 731     {
 732       if (scm_is_eq (SCM_CAR (walk), item))
 733         *prev = SCM_CDR (walk);
 734       else
 735         prev = SCM_CDRLOC (walk);
 736     }
 737
 738   return lst;
 739 }
 740 #undef FUNC_NAME
 741
 742
 743 SCM_DEFINE (scm_delv_x, "delv!", 2, 0, 0,
 744             (SCM item, SCM lst),
 745             "Destructively remove all elements from @var{lst} that are\n"
 746             "@code{eqv?} to @var{item}.")
 747 #define FUNC_NAME s_scm_delv_x
 748 {
 749   SCM walk;
 750   SCM *prev;
 751
 752   for (prev = &lst, walk = lst;
 753        scm_is_pair (walk);
 754        walk = SCM_CDR (walk))
 755     {
 756       if (! scm_is_false (scm_eqv_p (SCM_CAR (walk), item)))
 757         *prev = SCM_CDR (walk);
 758       else
 759         prev = SCM_CDRLOC (walk);
 760     }
 761
 762   return lst;
 763 }
 764 #undef FUNC_NAME
 765
 766
 767
 768 SCM_DEFINE (scm_delete_x, "delete!", 2, 0, 0,
 769             (SCM item, SCM lst),
 770             "Destructively remove all elements from @var{lst} that are\n"
 771             "@code{equal?} to @var{item}.")
 772 #define FUNC_NAME s_scm_delete_x
 773 {
 774   SCM walk;
 775   SCM *prev;
 776
 777   for (prev = &lst, walk = lst;
 778        scm_is_pair (walk);
 779        walk = SCM_CDR (walk))
 780     {
 781       if (! scm_is_false (scm_equal_p (SCM_CAR (walk), item)))
 782         *prev = SCM_CDR (walk);
 783       else
 784         prev = SCM_CDRLOC (walk);
 785     }
 786
 787   return lst;
 788 }
 789 #undef FUNC_NAME
 790
 791
 792 \f
 793
 794
 795 SCM_DEFINE (scm_delq, "delq", 2, 0, 0,
 796             (SCM item, SCM lst),
 797             "Return a newly-created copy of @var{lst} with elements\n"
 798             "@code{eq?} to @var{item} removed.  This procedure mirrors\n"
 799             "@code{memq}: @code{delq} compares elements of @var{lst} against\n"
 800             "@var{item} with @code{eq?}.")
 801 #define FUNC_NAME s_scm_delq
 802 {
 803   SCM copy = scm_list_copy (lst);
 804   return scm_delq_x (item, copy);
 805 }
 806 #undef FUNC_NAME
 807
 808 SCM_DEFINE (scm_delv, "delv", 2, 0, 0,
 809             (SCM item, SCM lst),
 810             "Return a newly-created copy of @var{lst} with elements\n"
 811             "@code{eqv?}  to @var{item} removed.  This procedure mirrors\n"
 812             "@code{memv}: @code{delv} compares elements of @var{lst} against\n"
 813             "@var{item} with @code{eqv?}.")
 814 #define FUNC_NAME s_scm_delv
 815 {
 816   SCM copy = scm_list_copy (lst);
 817   return scm_delv_x (item, copy);
 818 }
 819 #undef FUNC_NAME
 820
 821 SCM_DEFINE (scm_delete, "delete", 2, 0, 0,
 822             (SCM item, SCM lst),
 823             "Return a newly-created copy of @var{lst} with elements\n"
 824             "@code{equal?}  to @var{item} removed.  This procedure mirrors\n"
 825             "@code{member}: @code{delete} compares elements of @var{lst}\n"
 826             "against @var{item} with @code{equal?}.")
 827 #define FUNC_NAME s_scm_delete
 828 {
 829   SCM copy = scm_list_copy (lst);
 830   return scm_delete_x (item, copy);
 831 }
 832 #undef FUNC_NAME
 833
 834
 835 SCM_DEFINE (scm_delq1_x, "delq1!", 2, 0, 0,
 836            (SCM item, SCM lst),
 837             "Like @code{delq!}, but only deletes the first occurrence of\n"
 838             "@var{item} from @var{lst}.  Tests for equality using\n"
 839             "@code{eq?}.  See also @code{delv1!} and @code{delete1!}.")
 840 #define FUNC_NAME s_scm_delq1_x
 841 {
 842   SCM walk;
 843   SCM *prev;
 844
 845   for (prev = &lst, walk = lst;
 846        scm_is_pair (walk);
 847        walk = SCM_CDR (walk))
 848     {
 849       if (scm_is_eq (SCM_CAR (walk), item))
 850         {
 851           *prev = SCM_CDR (walk);
 852           break;
 853         }
 854       else
 855         prev = SCM_CDRLOC (walk);
 856     }
 857
 858   return lst;
 859 }
 860 #undef FUNC_NAME
 861
 862
 863 SCM_DEFINE (scm_delv1_x, "delv1!", 2, 0, 0,
 864             (SCM item, SCM lst),
 865             "Like @code{delv!}, but only deletes the first occurrence of\n"
 866             "@var{item} from @var{lst}.  Tests for equality using\n"
 867             "@code{eqv?}.  See also @code{delq1!} and @code{delete1!}.")
 868 #define FUNC_NAME s_scm_delv1_x
 869 {
 870   SCM walk;
 871   SCM *prev;
 872
 873   for (prev = &lst, walk = lst;
 874        scm_is_pair (walk);
 875        walk = SCM_CDR (walk))
 876     {
 877       if (! scm_is_false (scm_eqv_p (SCM_CAR (walk), item)))
 878         {
 879           *prev = SCM_CDR (walk);
 880           break;
 881         }
 882       else
 883         prev = SCM_CDRLOC (walk);
 884     }
 885
 886   return lst;
 887 }
 888 #undef FUNC_NAME
 889
 890
 891 SCM_DEFINE (scm_delete1_x, "delete1!", 2, 0, 0,
 892             (SCM item, SCM lst),
 893             "Like @code{delete!}, but only deletes the first occurrence of\n"
 894             "@var{item} from @var{lst}.  Tests for equality using\n"
 895             "@code{equal?}.  See also @code{delq1!} and @code{delv1!}.")
 896 #define FUNC_NAME s_scm_delete1_x
 897 {
 898   SCM walk;
 899   SCM *prev;
 900
 901   for (prev = &lst, walk = lst;
 902        scm_is_pair (walk);
 903        walk = SCM_CDR (walk))
 904     {
 905       if (! scm_is_false (scm_equal_p (SCM_CAR (walk), item)))
 906         {
 907           *prev = SCM_CDR (walk);
 908           break;
 909         }
 910       else
 911         prev = SCM_CDRLOC (walk);
 912     }
 913
 914   return lst;
 915 }
 916 #undef FUNC_NAME
 917
 918 SCM_DEFINE (scm_filter, "filter", 2, 0, 0,
 919             (SCM pred, SCM list),
 920             "Return all the elements of 2nd arg @var{list} that satisfy predicate @var{pred}.\n"
 921             "The list is not disordered -- elements that appear in the result list occur\n"
 922             "in the same order as they occur in the argument list. The returned list may\n"
 923             "share a common tail with the argument list. The dynamic order in which the\n"
 924             "various applications of pred are made is not specified.\n\n"
 925             "@lisp\n"
 926             "(filter even? '(0 7 8 8 43 -4)) => (0 8 8 -4)\n"
 927             "@end lisp")
 928 #define FUNC_NAME s_scm_filter
 929 {
 930   SCM walk;
 931   SCM *prev;
 932   SCM res = SCM_EOL;
 933   SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, 1, FUNC_NAME);
 934   SCM_VALIDATE_LIST (2, list);
 935
 936   for (prev = &res, walk = list;
 937        scm_is_pair (walk);
 938        walk = SCM_CDR (walk))
 939     {
 940       if (scm_is_true (scm_call_1 (pred, SCM_CAR (walk))))
 941         {
 942           *prev = scm_cons (SCM_CAR (walk), SCM_EOL);
 943           prev = SCM_CDRLOC (*prev);
 944         }
 945     }
 946
 947   return res;
 948 }
 949 #undef FUNC_NAME
 950
 951 SCM_DEFINE (scm_filter_x, "filter!", 2, 0, 0,
 952             (SCM pred, SCM list),
 953             "Linear-update variant of @code{filter}.")
 954 #define FUNC_NAME s_scm_filter_x
 955 {
 956   SCM walk;
 957   SCM *prev;
 958   SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, 1, FUNC_NAME);
 959   SCM_VALIDATE_LIST (2, list);
 960
 961   for (prev = &list, walk = list;
 962        scm_is_pair (walk);
 963        walk = SCM_CDR (walk))
 964     {
 965       if (scm_is_true (scm_call_1 (pred, SCM_CAR (walk))))
 966         prev = SCM_CDRLOC (walk);
 967       else
 968         *prev = SCM_CDR (walk);
 969     }
 970
 971   return list;
 972 }
 973 #undef FUNC_NAME
 974
 975 \f
 976 void
 977 scm_init_list ()
 978 {
 979 #include "libguile/list.x"
 980 }
 981
 982 /*
 983   Local Variables:
 984   c-file-style: "gnu"
 985   End:
 986 */