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 args),
 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   int argnum = 1;
 280   SCM_VALIDATE_REST_ARGUMENT (args);
 281
 282   if (scm_is_null (args))
 283     return SCM_EOL;
 284
 285   loc = &ret;
 286   for (;;)
 287     {
 288       SCM arg = SCM_CAR (args);
 289       *loc = arg;
 290
 291       args = SCM_CDR (args);
 292       if (scm_is_null (args))
 293         return ret;
 294
 295       if (!SCM_NULL_OR_NIL_P (arg))
 296         {
 297           SCM_VALIDATE_CONS (argnum, arg);
 298           loc = SCM_CDRLOC (scm_last_pair (arg));
 299           SCM_VALIDATE_NULL_OR_NIL (argnum, *loc);
 300         }
 301       argnum++;
 302     }
 303 }
 304 #undef FUNC_NAME
 305
 306
 307 SCM_DEFINE (scm_last_pair, "last-pair", 1, 0, 0,
 308            (SCM lst),
 309             "Return the last pair in @var{lst}, signalling an error if\n"
 310             "@var{lst} is circular.")
 311 #define FUNC_NAME s_scm_last_pair
 312 {
 313   SCM tortoise = lst;
 314   SCM hare = lst;
 315
 316   if (SCM_NULL_OR_NIL_P (lst))
 317     return lst;
 318
 319   SCM_VALIDATE_CONS (SCM_ARG1, lst);
 320   do {
 321     SCM ahead = SCM_CDR(hare);
 322     if (!scm_is_pair (ahead)) return hare;
 323     hare = ahead;
 324     ahead = SCM_CDR(hare);
 325     if (!scm_is_pair (ahead)) return hare;
 326     hare = ahead;
 327     tortoise = SCM_CDR(tortoise);
 328   }
 329   while (!scm_is_eq (hare, tortoise));
 330   SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst));
 331 }
 332 #undef FUNC_NAME
 333
 334 \f
 335 /* reversing lists */
 336
 337 SCM_DEFINE (scm_reverse, "reverse", 1, 0, 0,
 338             (SCM lst),
 339             "Return a new list that contains the elements of @var{lst} but\n"
 340             "in reverse order.")
 341 #define FUNC_NAME s_scm_reverse
 342 {
 343   SCM result = SCM_EOL;
 344   SCM tortoise = lst;
 345   SCM hare = lst;
 346
 347   do {
 348       if (SCM_NULL_OR_NIL_P(hare)) return result;
 349       SCM_ASSERT(scm_is_pair(hare), lst, 1, FUNC_NAME);
 350       result = scm_cons (SCM_CAR (hare), result);
 351       hare = SCM_CDR (hare);
 352       if (SCM_NULL_OR_NIL_P(hare)) return result;
 353       SCM_ASSERT(scm_is_pair(hare), lst, 1, FUNC_NAME);
 354       result = scm_cons (SCM_CAR (hare), result);
 355       hare = SCM_CDR (hare);
 356       tortoise = SCM_CDR (tortoise);
 357     }
 358   while (!scm_is_eq (hare, tortoise));
 359   SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst));
 360 }
 361 #undef FUNC_NAME
 362
 363 SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0,
 364             (SCM lst, SCM new_tail),
 365             "A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r5rs,\n"
 366             "The Revised^5 Report on Scheme}).  The cdr of each cell in @var{lst} is\n"
 367             "modified to point to the previous list element.  Return the\n"
 368             "reversed list.\n\n"
 369             "Caveat: because the list is modified in place, the tail of the original\n"
 370             "list now becomes its head, and the head of the original list now becomes\n"
 371             "the tail.  Therefore, the @var{lst} symbol to which the head of the\n"
 372             "original list was bound now points to the tail.  To ensure that the head\n"
 373             "of the modified list is not lost, it is wise to save the return value of\n"
 374             "@code{reverse!}")
 375 #define FUNC_NAME s_scm_reverse_x
 376 {
 377   SCM_VALIDATE_LIST (1, lst);
 378   if (SCM_UNBNDP (new_tail))
 379     new_tail = SCM_EOL;
 380
 381   while (!SCM_NULL_OR_NIL_P (lst))
 382     {
 383       SCM old_tail = SCM_CDR (lst);
 384       SCM_SETCDR (lst, new_tail);
 385       new_tail = lst;
 386       lst = old_tail;
 387     }
 388   return new_tail;
 389 }
 390 #undef FUNC_NAME
 391
 392 \f
 393
 394 /* indexing lists by element number */
 395
 396 SCM_DEFINE (scm_list_ref, "list-ref", 2, 0, 0,
 397             (SCM list, SCM k),
 398             "Return the @var{k}th element from @var{list}.")
 399 #define FUNC_NAME s_scm_list_ref
 400 {
 401   SCM lst = list;
 402   unsigned long int i;
 403   i = scm_to_ulong (k);
 404   while (scm_is_pair (lst)) {
 405     if (i == 0)
 406       return SCM_CAR (lst);
 407     else {
 408       --i;
 409       lst = SCM_CDR (lst);
 410     }
 411   };
 412   if (SCM_NULL_OR_NIL_P (lst))
 413     SCM_OUT_OF_RANGE (2, k);
 414   else
 415     SCM_WRONG_TYPE_ARG (1, list);
 416 }
 417 #undef FUNC_NAME
 418
 419
 420 SCM_DEFINE (scm_list_set_x, "list-set!", 3, 0, 0,
 421             (SCM list, SCM k, SCM val),
 422             "Set the @var{k}th element of @var{list} to @var{val}.")
 423 #define FUNC_NAME s_scm_list_set_x
 424 {
 425   SCM lst = list;
 426   unsigned long int i = scm_to_ulong (k);
 427   while (scm_is_pair (lst)) {
 428     if (i == 0) {
 429       SCM_SETCAR (lst, val);
 430       return val;
 431     } else {
 432       --i;
 433       lst = SCM_CDR (lst);
 434     }
 435   };
 436   if (SCM_NULL_OR_NIL_P (lst))
 437     SCM_OUT_OF_RANGE (2, k);
 438   else
 439     SCM_WRONG_TYPE_ARG (1, list);
 440 }
 441 #undef FUNC_NAME
 442
 443
 444 SCM_REGISTER_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail);
 445
 446 SCM_DEFINE (scm_list_tail, "list-tail", 2, 0, 0,
 447            (SCM lst, SCM k),
 448             "@deffnx {Scheme Procedure} list-cdr-ref lst k\n"
 449             "Return the \"tail\" of @var{lst} beginning with its @var{k}th element.\n"
 450             "The first element of the list is considered to be element 0.\n\n"
 451             "@code{list-tail} and @code{list-cdr-ref} are identical.  It may help to\n"
 452             "think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list,\n"
 453             "or returning the results of cdring @var{k} times down @var{lst}.")
 454 #define FUNC_NAME s_scm_list_tail
 455 {
 456   size_t i = scm_to_size_t (k);
 457   while (i-- > 0) {
 458     SCM_VALIDATE_CONS (1, lst);
 459     lst = SCM_CDR(lst);
 460   }
 461   return lst;
 462 }
 463 #undef FUNC_NAME
 464
 465
 466 SCM_DEFINE (scm_list_cdr_set_x, "list-cdr-set!", 3, 0, 0,
 467            (SCM list, SCM k, SCM val),
 468             "Set the @var{k}th cdr of @var{list} to @var{val}.")
 469 #define FUNC_NAME s_scm_list_cdr_set_x
 470 {
 471   SCM lst = list;
 472   size_t i = scm_to_size_t (k);
 473   while (scm_is_pair (lst)) {
 474     if (i == 0) {
 475       SCM_SETCDR (lst, val);
 476       return val;
 477     } else {
 478       --i;
 479       lst = SCM_CDR (lst);
 480     }
 481   };
 482   if (SCM_NULL_OR_NIL_P (lst))
 483     SCM_OUT_OF_RANGE (2, k);
 484   else
 485     SCM_WRONG_TYPE_ARG (1, list);
 486 }
 487 #undef FUNC_NAME
 488
 489
 490 \f
 491 /* copying lists, perhaps partially */
 492
 493 SCM_DEFINE (scm_list_head, "list-head", 2, 0, 0,
 494            (SCM lst, SCM k),
 495             "Copy the first @var{k} elements from @var{lst} into a new list, and\n"
 496             "return it.")
 497 #define FUNC_NAME s_scm_list_head
 498 {
 499   SCM answer;
 500   SCM * pos;
 501   size_t i = scm_to_size_t (k);
 502
 503   answer = SCM_EOL;
 504   pos = &answer;
 505   while (i-- > 0)
 506     {
 507       SCM_VALIDATE_CONS (1, lst);
 508       *pos = scm_cons (SCM_CAR (lst), SCM_EOL);
 509       pos = SCM_CDRLOC (*pos);
 510       lst = SCM_CDR(lst);
 511     }
 512   return answer;
 513 }
 514 #undef FUNC_NAME
 515
 516
 517 /* Copy a list which is known to be finite.  The last pair may or may not have
 518  * a '() in its cdr.  That is, improper lists are accepted.  */
 519 SCM
 520 scm_i_finite_list_copy (SCM list)
 521 {
 522   if (!scm_is_pair (list))
 523     {
 524       return list;
 525     }
 526   else
 527     {
 528       SCM tail;
 529       const SCM result = tail = scm_list_1 (SCM_CAR (list));
 530       list = SCM_CDR (list);
 531       while (scm_is_pair (list))
 532         {
 533           const SCM new_tail = scm_list_1 (SCM_CAR (list));
 534           SCM_SETCDR (tail, new_tail);
 535           tail = new_tail;
 536           list = SCM_CDR (list);
 537         }
 538       SCM_SETCDR (tail, list);
 539
 540       return result;
 541     }
 542 }
 543
 544
 545 SCM_DEFINE (scm_list_copy, "list-copy", 1, 0, 0,
 546             (SCM lst),
 547             "Return a (newly-created) copy of @var{lst}.")
 548 #define FUNC_NAME s_scm_list_copy
 549 {
 550   SCM newlst;
 551   SCM * fill_here;
 552   SCM from_here;
 553
 554   SCM_VALIDATE_LIST (1, lst);
 555
 556   newlst = SCM_EOL;
 557   fill_here = &newlst;
 558   from_here = lst;
 559
 560   while (scm_is_pair (from_here))
 561     {
 562       SCM c;
 563       c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here));
 564       *fill_here = c;
 565       fill_here = SCM_CDRLOC (c);
 566       from_here = SCM_CDR (from_here);
 567     }
 568   return newlst;
 569 }
 570 #undef FUNC_NAME
 571
 572
 573 SCM_PROC (s_list, "list", 0, 0, 1, scm_list_copy);
 574 SCM_SNARF_DOCS (primitive, scm_list_copy, "list", (SCM objs), 0, 0, 1,
 575                 "Return a list containing @var{objs}, the arguments to\n"
 576                 "@code{list}.")
 577
 578 /* This used to be the code for "list", but it's wrong when used via apply
 579    (it should copy the list).  It seems pretty unlikely anyone would have
 580    been using this from C code, since it's a no-op, but keep it for strict
 581    binary compatibility.  */
 582 SCM
 583 scm_list (SCM objs)
 584 {
 585   return objs;
 586 }
 587
 588
 589 \f
 590 /* membership tests (memq, memv, etc.) */
 591
 592 /* The function scm_c_memq returns the first sublist of list whose car is
 593  * 'eq?' obj, where the sublists of list are the non-empty lists returned by
 594  * (list-tail list k) for k less than the length of list.  If obj does not
 595  * occur in list, then #f (not the empty list) is returned.
 596  * List must be a proper list, otherwise scm_c_memq may crash or loop
 597  * endlessly.
 598  */
 599 SCM
 600 scm_c_memq (SCM obj, SCM list)
 601 {
 602   for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR (list))
 603     {
 604       if (scm_is_eq (SCM_CAR (list), obj))
 605         return list;
 606     }
 607   return SCM_BOOL_F;
 608 }
 609
 610
 611 SCM_DEFINE (scm_memq, "memq", 2, 0, 0,
 612            (SCM x, SCM lst),
 613             "Return the first sublist of @var{lst} whose car is @code{eq?}\n"
 614             "to @var{x} where the sublists of @var{lst} are the non-empty\n"
 615             "lists returned by @code{(list-tail @var{lst} @var{k})} for\n"
 616             "@var{k} less than the length of @var{lst}.  If @var{x} does not\n"
 617             "occur in @var{lst}, then @code{#f} (not the empty list) is\n"
 618             "returned.")
 619 #define FUNC_NAME s_scm_memq
 620 {
 621   SCM hare = lst, tortoise = lst;
 622
 623   while (scm_is_pair (hare))
 624     {
 625       if (scm_is_eq (SCM_CAR (hare), x))
 626         return hare;
 627       else
 628         hare = SCM_CDR (hare);
 629
 630       if (!scm_is_pair (hare))
 631         break;
 632
 633       if (scm_is_eq (SCM_CAR (hare), x))
 634         return hare;
 635       else
 636         hare = SCM_CDR (hare);
 637
 638       tortoise = SCM_CDR (tortoise);
 639       if (SCM_UNLIKELY (scm_is_eq (hare, tortoise)))
 640         break;
 641     }
 642
 643   if (SCM_LIKELY (scm_is_null (hare)))
 644     return SCM_BOOL_F;
 645   else
 646     scm_wrong_type_arg_msg (FUNC_NAME, 2, lst, "list");
 647 }
 648 #undef FUNC_NAME
 649
 650
 651 SCM_DEFINE (scm_memv, "memv", 2, 0, 0,
 652            (SCM x, SCM lst),
 653             "Return the first sublist of @var{lst} whose car is @code{eqv?}\n"
 654             "to @var{x} where the sublists of @var{lst} are the non-empty\n"
 655             "lists returned by @code{(list-tail @var{lst} @var{k})} for\n"
 656             "@var{k} less than the length of @var{lst}.  If @var{x} does not\n"
 657             "occur in @var{lst}, then @code{#f} (not the empty list) is\n"
 658             "returned.")
 659 #define FUNC_NAME s_scm_memv
 660 {
 661   SCM hare = lst, tortoise = lst;
 662
 663   while (scm_is_pair (hare))
 664     {
 665       if (scm_is_true (scm_eqv_p (SCM_CAR (hare), x)))
 666         return hare;
 667       else
 668         hare = SCM_CDR (hare);
 669
 670       if (!scm_is_pair (hare))
 671         break;
 672
 673       if (scm_is_true (scm_eqv_p (SCM_CAR (hare), x)))
 674         return hare;
 675       else
 676         hare = SCM_CDR (hare);
 677
 678       tortoise = SCM_CDR (tortoise);
 679       if (SCM_UNLIKELY (scm_is_eq (hare, tortoise)))
 680         break;
 681     }
 682
 683   if (SCM_LIKELY (scm_is_null (hare)))
 684     return SCM_BOOL_F;
 685   else
 686     scm_wrong_type_arg_msg (FUNC_NAME, 2, lst, "list");
 687 }
 688 #undef FUNC_NAME
 689
 690
 691 SCM_DEFINE (scm_member, "member", 2, 0, 0,
 692            (SCM x, SCM lst),
 693             "Return the first sublist of @var{lst} whose car is\n"
 694             "@code{equal?} to @var{x} where the sublists of @var{lst} are\n"
 695             "the non-empty lists returned by @code{(list-tail @var{lst}\n"
 696             "@var{k})} for @var{k} less than the length of @var{lst}.  If\n"
 697             "@var{x} does not occur in @var{lst}, then @code{#f} (not the\n"
 698             "empty list) is returned.")
 699 #define FUNC_NAME s_scm_member
 700 {
 701   SCM_VALIDATE_LIST (2, lst);
 702   for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
 703     {
 704       if (! scm_is_false (scm_equal_p (SCM_CAR (lst), x)))
 705         return lst;
 706     }
 707   return SCM_BOOL_F;
 708 }
 709 #undef FUNC_NAME
 710
 711 \f
 712 /* deleting elements from a list (delq, etc.) */
 713
 714 SCM_DEFINE (scm_delq_x, "delq!", 2, 0, 0,
 715            (SCM item, SCM lst),
 716             "@deffnx {Scheme Procedure} delv! item lst\n"
 717             "@deffnx {Scheme Procedure} delete! item lst\n"
 718             "These procedures are destructive versions of @code{delq}, @code{delv}\n"
 719             "and @code{delete}: they modify the existing @var{lst}\n"
 720             "rather than creating a new list.  Caveat evaluator: Like other\n"
 721             "destructive list functions, these functions cannot modify the binding of\n"
 722             "@var{lst}, and so cannot be used to delete the first element of\n"
 723             "@var{lst} destructively.")
 724 #define FUNC_NAME s_scm_delq_x
 725 {
 726   SCM walk;
 727   SCM *prev;
 728
 729   for (prev = &lst, walk = lst;
 730        scm_is_pair (walk);
 731        walk = SCM_CDR (walk))
 732     {
 733       if (scm_is_eq (SCM_CAR (walk), item))
 734         *prev = SCM_CDR (walk);
 735       else
 736         prev = SCM_CDRLOC (walk);
 737     }
 738
 739   return lst;
 740 }
 741 #undef FUNC_NAME
 742
 743
 744 SCM_DEFINE (scm_delv_x, "delv!", 2, 0, 0,
 745             (SCM item, SCM lst),
 746             "Destructively remove all elements from @var{lst} that are\n"
 747             "@code{eqv?} to @var{item}.")
 748 #define FUNC_NAME s_scm_delv_x
 749 {
 750   SCM walk;
 751   SCM *prev;
 752
 753   for (prev = &lst, walk = lst;
 754        scm_is_pair (walk);
 755        walk = SCM_CDR (walk))
 756     {
 757       if (! scm_is_false (scm_eqv_p (SCM_CAR (walk), item)))
 758         *prev = SCM_CDR (walk);
 759       else
 760         prev = SCM_CDRLOC (walk);
 761     }
 762
 763   return lst;
 764 }
 765 #undef FUNC_NAME
 766
 767
 768
 769 SCM_DEFINE (scm_delete_x, "delete!", 2, 0, 0,
 770             (SCM item, SCM lst),
 771             "Destructively remove all elements from @var{lst} that are\n"
 772             "@code{equal?} to @var{item}.")
 773 #define FUNC_NAME s_scm_delete_x
 774 {
 775   SCM walk;
 776   SCM *prev;
 777
 778   for (prev = &lst, walk = lst;
 779        scm_is_pair (walk);
 780        walk = SCM_CDR (walk))
 781     {
 782       if (! scm_is_false (scm_equal_p (SCM_CAR (walk), item)))
 783         *prev = SCM_CDR (walk);
 784       else
 785         prev = SCM_CDRLOC (walk);
 786     }
 787
 788   return lst;
 789 }
 790 #undef FUNC_NAME
 791
 792
 793 \f
 794
 795
 796 SCM_DEFINE (scm_delq, "delq", 2, 0, 0,
 797             (SCM item, SCM lst),
 798             "Return a newly-created copy of @var{lst} with elements\n"
 799             "@code{eq?} to @var{item} removed.  This procedure mirrors\n"
 800             "@code{memq}: @code{delq} compares elements of @var{lst} against\n"
 801             "@var{item} with @code{eq?}.")
 802 #define FUNC_NAME s_scm_delq
 803 {
 804   SCM copy = scm_list_copy (lst);
 805   return scm_delq_x (item, copy);
 806 }
 807 #undef FUNC_NAME
 808
 809 SCM_DEFINE (scm_delv, "delv", 2, 0, 0,
 810             (SCM item, SCM lst),
 811             "Return a newly-created copy of @var{lst} with elements\n"
 812             "@code{eqv?}  to @var{item} removed.  This procedure mirrors\n"
 813             "@code{memv}: @code{delv} compares elements of @var{lst} against\n"
 814             "@var{item} with @code{eqv?}.")
 815 #define FUNC_NAME s_scm_delv
 816 {
 817   SCM copy = scm_list_copy (lst);
 818   return scm_delv_x (item, copy);
 819 }
 820 #undef FUNC_NAME
 821
 822 SCM_DEFINE (scm_delete, "delete", 2, 0, 0,
 823             (SCM item, SCM lst),
 824             "Return a newly-created copy of @var{lst} with elements\n"
 825             "@code{equal?}  to @var{item} removed.  This procedure mirrors\n"
 826             "@code{member}: @code{delete} compares elements of @var{lst}\n"
 827             "against @var{item} with @code{equal?}.")
 828 #define FUNC_NAME s_scm_delete
 829 {
 830   SCM copy = scm_list_copy (lst);
 831   return scm_delete_x (item, copy);
 832 }
 833 #undef FUNC_NAME
 834
 835
 836 SCM_DEFINE (scm_delq1_x, "delq1!", 2, 0, 0,
 837            (SCM item, SCM lst),
 838             "Like @code{delq!}, but only deletes the first occurrence of\n"
 839             "@var{item} from @var{lst}.  Tests for equality using\n"
 840             "@code{eq?}.  See also @code{delv1!} and @code{delete1!}.")
 841 #define FUNC_NAME s_scm_delq1_x
 842 {
 843   SCM walk;
 844   SCM *prev;
 845
 846   for (prev = &lst, walk = lst;
 847        scm_is_pair (walk);
 848        walk = SCM_CDR (walk))
 849     {
 850       if (scm_is_eq (SCM_CAR (walk), item))
 851         {
 852           *prev = SCM_CDR (walk);
 853           break;
 854         }
 855       else
 856         prev = SCM_CDRLOC (walk);
 857     }
 858
 859   return lst;
 860 }
 861 #undef FUNC_NAME
 862
 863
 864 SCM_DEFINE (scm_delv1_x, "delv1!", 2, 0, 0,
 865             (SCM item, SCM lst),
 866             "Like @code{delv!}, but only deletes the first occurrence of\n"
 867             "@var{item} from @var{lst}.  Tests for equality using\n"
 868             "@code{eqv?}.  See also @code{delq1!} and @code{delete1!}.")
 869 #define FUNC_NAME s_scm_delv1_x
 870 {
 871   SCM walk;
 872   SCM *prev;
 873
 874   for (prev = &lst, walk = lst;
 875        scm_is_pair (walk);
 876        walk = SCM_CDR (walk))
 877     {
 878       if (! scm_is_false (scm_eqv_p (SCM_CAR (walk), item)))
 879         {
 880           *prev = SCM_CDR (walk);
 881           break;
 882         }
 883       else
 884         prev = SCM_CDRLOC (walk);
 885     }
 886
 887   return lst;
 888 }
 889 #undef FUNC_NAME
 890
 891
 892 SCM_DEFINE (scm_delete1_x, "delete1!", 2, 0, 0,
 893             (SCM item, SCM lst),
 894             "Like @code{delete!}, but only deletes the first occurrence of\n"
 895             "@var{item} from @var{lst}.  Tests for equality using\n"
 896             "@code{equal?}.  See also @code{delq1!} and @code{delv1!}.")
 897 #define FUNC_NAME s_scm_delete1_x
 898 {
 899   SCM walk;
 900   SCM *prev;
 901
 902   for (prev = &lst, walk = lst;
 903        scm_is_pair (walk);
 904        walk = SCM_CDR (walk))
 905     {
 906       if (! scm_is_false (scm_equal_p (SCM_CAR (walk), item)))
 907         {
 908           *prev = SCM_CDR (walk);
 909           break;
 910         }
 911       else
 912         prev = SCM_CDRLOC (walk);
 913     }
 914
 915   return lst;
 916 }
 917 #undef FUNC_NAME
 918
 919 SCM_DEFINE (scm_filter, "filter", 2, 0, 0,
 920             (SCM pred, SCM list),
 921             "Return all the elements of 2nd arg @var{list} that satisfy predicate @var{pred}.\n"
 922             "The list is not disordered -- elements that appear in the result list occur\n"
 923             "in the same order as they occur in the argument list. The returned list may\n"
 924             "share a common tail with the argument list. The dynamic order in which the\n"
 925             "various applications of pred are made is not specified.\n\n"
 926             "@lisp\n"
 927             "(filter even? '(0 7 8 8 43 -4)) => (0 8 8 -4)\n"
 928             "@end lisp")
 929 #define FUNC_NAME s_scm_filter
 930 {
 931   SCM walk;
 932   SCM *prev;
 933   SCM res = SCM_EOL;
 934   SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, 1, FUNC_NAME);
 935   SCM_VALIDATE_LIST (2, list);
 936
 937   for (prev = &res, walk = list;
 938        scm_is_pair (walk);
 939        walk = SCM_CDR (walk))
 940     {
 941       if (scm_is_true (scm_call_1 (pred, SCM_CAR (walk))))
 942         {
 943           *prev = scm_cons (SCM_CAR (walk), SCM_EOL);
 944           prev = SCM_CDRLOC (*prev);
 945         }
 946     }
 947
 948   return res;
 949 }
 950 #undef FUNC_NAME
 951
 952 SCM_DEFINE (scm_filter_x, "filter!", 2, 0, 0,
 953             (SCM pred, SCM list),
 954             "Linear-update variant of @code{filter}.")
 955 #define FUNC_NAME s_scm_filter_x
 956 {
 957   SCM walk;
 958   SCM *prev;
 959   SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, 1, FUNC_NAME);
 960   SCM_VALIDATE_LIST (2, list);
 961
 962   for (prev = &list, walk = list;
 963        scm_is_pair (walk);
 964        walk = SCM_CDR (walk))
 965     {
 966       if (scm_is_true (scm_call_1 (pred, SCM_CAR (walk))))
 967         prev = SCM_CDRLOC (walk);
 968       else
 969         *prev = SCM_CDR (walk);
 970     }
 971
 972   return list;
 973 }
 974 #undef FUNC_NAME
 975
 976 \f
 977 void
 978 scm_init_list ()
 979 {
 980 #include "libguile/list.x"
 981 }
 982
 983 /*
 984   Local Variables:
 985   c-file-style: "gnu"
 986   End:
 987 */