libguile/list.c

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