libguile/list.c

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