libguile/list.c

   1 /*      Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program 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
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  46 #include <stdio.h>
  47 #include "libguile/_scm.h"
  48 #include "libguile/eq.h"
  49
  50 #include "libguile/validate.h"
  51 #include "libguile/list.h"
  52
  53 #ifdef __STDC__
  54 #include <stdarg.h>
  55 #define var_start(x, y) va_start(x, y)
  56 #else
  57 #include <varargs.h>
  58 #define var_start(x, y) va_start(x)
  59 #endif
  60
  61 \f
  62 /* creating lists */
  63
  64 SCM
  65 scm_listify (SCM elt, ...)
  66 {
  67   va_list foo;
  68   SCM answer = SCM_EOL;
  69   SCM *pos = &answer;
  70
  71   var_start (foo, elt);
  72   while (! SCM_UNBNDP (elt))
  73     {
  74       *pos = scm_cons (elt, SCM_EOL);
  75       pos = SCM_CDRLOC (*pos);
  76       elt = va_arg (foo, SCM);
  77     }
  78   return answer;
  79 }
  80
  81
  82 SCM_DEFINE (scm_list, "list", 0, 0, 1,
  83            (SCM objs),
  84             "Return a list containing OBJS, the arguments to `list'.")
  85 #define FUNC_NAME s_scm_list
  86 {
  87   return objs;
  88 }
  89 #undef FUNC_NAME
  90
  91
  92 SCM_DEFINE (scm_list_star, "list*", 1, 0, 1,
  93             (SCM arg, SCM rest),
  94             "Return an improper list of the arguments.")
  95 #define FUNC_NAME s_scm_list_star
  96 {
  97   if (SCM_NNULLP (rest))
  98     {
  99       SCM prev = arg = scm_cons (arg, rest);
 100       while (SCM_NNULLP (SCM_CDR (rest)))
 101         {
 102           prev = rest;
 103           rest = SCM_CDR (rest);
 104         }
 105       SCM_SETCDR (prev, SCM_CAR (rest));
 106     }
 107   return arg;
 108 }
 109 #undef FUNC_NAME
 110
 111
 112 \f
 113 /* general questions about lists --- null?, list?, length, etc.  */
 114
 115 SCM_DEFINE (scm_null_p, "null?", 1, 0, 0,
 116            (SCM x),
 117             "Return #t iff X is the empty list, else #f.")
 118 #define FUNC_NAME s_scm_null_p
 119 {
 120   return SCM_BOOL (SCM_NULLP (x));
 121 }
 122 #undef FUNC_NAME
 123
 124
 125 SCM_DEFINE (scm_list_p, "list?", 1, 0, 0,
 126            (SCM x),
 127             "Return #t iff X is a proper list, else #f.")
 128 #define FUNC_NAME s_scm_list_p
 129 {
 130   return SCM_BOOL (scm_ilength (x) >= 0);
 131 }
 132 #undef FUNC_NAME
 133
 134
 135 /* Return the length of SX, or -1 if it's not a proper list.
 136    This uses the "tortoise and hare" algorithm to detect "infinitely
 137    long" lists (i.e. lists with cycles in their cdrs), and returns -1
 138    if it does find one.  */
 139 long
 140 scm_ilength(SCM sx)
 141 {
 142   long i = 0;
 143   SCM tortoise = sx;
 144   SCM hare = sx;
 145
 146   do {
 147     if (SCM_NULLP(hare)) return i;
 148     if (SCM_NCONSP(hare)) return -1;
 149     hare = SCM_CDR(hare);
 150     i++;
 151     if (SCM_NULLP(hare)) return i;
 152     if (SCM_NCONSP(hare)) return -1;
 153     hare = SCM_CDR(hare);
 154     i++;
 155     /* For every two steps the hare takes, the tortoise takes one.  */
 156     tortoise = SCM_CDR(tortoise);
 157   }
 158   while (! SCM_EQ_P (hare, tortoise));
 159
 160   /* If the tortoise ever catches the hare, then the list must contain
 161      a cycle.  */
 162   return -1;
 163 }
 164
 165
 166 SCM_DEFINE (scm_length, "length", 1, 0, 0,
 167            (SCM lst),
 168             "Return the number of elements in list LST.")
 169 #define FUNC_NAME s_scm_length
 170 {
 171   int i;
 172   SCM_VALIDATE_LIST_COPYLEN (1,lst,i);
 173   return SCM_MAKINUM (i);
 174 }
 175 #undef FUNC_NAME
 176
 177
 178 \f
 179 /* appending lists */
 180
 181 SCM_DEFINE (scm_append, "append", 0, 0, 1,
 182             (SCM args),
 183             "Returns a list consisting of the elements of the first LIST\n"
 184             "followed by the elements of the other LISTs.\n"
 185             "\n"
 186             "  (append '(x) '(y))          =>  (x y)\n"
 187             "  (append '(a) '(b c d))      =>  (a b c d)\n"
 188             "  (append '(a (b)) '((c)))    =>  (a (b) (c))\n"
 189             "\n"
 190             "The resulting list is always newly allocated, except that it shares\n"
 191             "structure with the last LIST argument.  The last argument may\n"
 192             "actually be any object; an improper list results if the last\n"
 193             "argument is not a proper list.\n"
 194
 195             "  (append '(a b) '(c . d))    =>  (a b c . d)\n"
 196             "  (append '() 'a)             =>  a\n")
 197 #define FUNC_NAME s_scm_append
 198 {
 199   SCM res = SCM_EOL;
 200   SCM *lloc = &res, arg;
 201   if (SCM_IMP(args)) {
 202     SCM_VALIDATE_NULL (SCM_ARGn, args);
 203     return res;
 204   }
 205   SCM_VALIDATE_CONS (SCM_ARGn, args);
 206   while (1) {
 207     arg = SCM_CAR(args);
 208     args = SCM_CDR(args);
 209     if (SCM_IMP(args)) {
 210       *lloc = arg;
 211       SCM_VALIDATE_NULL (SCM_ARGn, args);
 212       return res;
 213     }
 214     SCM_VALIDATE_CONS (SCM_ARGn, args);
 215     for (; SCM_CONSP(arg); arg = SCM_CDR(arg)) {
 216       *lloc = scm_cons(SCM_CAR(arg), SCM_EOL);
 217       lloc = SCM_CDRLOC(*lloc);
 218     }
 219     SCM_VALIDATE_NULL (SCM_ARGn, arg);
 220   }
 221 }
 222 #undef FUNC_NAME
 223
 224
 225 SCM_DEFINE (scm_append_x, "append!", 0, 0, 1,
 226             (SCM args),
 227             "A destructive version of @code{append} (@pxref{Pairs and Lists,,,r4rs,\n"
 228             "The Revised^4 Report on Scheme}).  The cdr field of each list's final\n"
 229             "pair is changed to point to the head of the next list, so no consing is\n"
 230             "performed.  Return a pointer to the mutated list.")
 231 #define FUNC_NAME s_scm_append_x
 232 {
 233   SCM arg;
 234  tail:
 235   if (SCM_NULLP(args)) return SCM_EOL;
 236   arg = SCM_CAR(args);
 237   args = SCM_CDR(args);
 238   if (SCM_NULLP(args)) return arg;
 239   if (SCM_NULLP(arg)) goto tail;
 240   SCM_VALIDATE_CONS (SCM_ARG1,arg);
 241   SCM_SETCDR (scm_last_pair (arg), scm_append_x (args));
 242   return arg;
 243 }
 244 #undef FUNC_NAME
 245
 246
 247 SCM_DEFINE (scm_last_pair, "last-pair", 1, 0, 0,
 248            (SCM lst),
 249             "Return a pointer to the last pair in @var{lst}, signalling an error if\n"
 250             "@var{lst} is circular.")
 251 #define FUNC_NAME s_scm_last_pair
 252 {
 253   SCM tortoise = lst;
 254   SCM hare = lst;
 255
 256   if (SCM_NULLP (lst))
 257     return SCM_EOL;
 258
 259   SCM_VALIDATE_CONS (SCM_ARG1, lst);
 260   do {
 261     SCM ahead = SCM_CDR(hare);
 262     if (SCM_NCONSP(ahead)) return hare;
 263     hare = ahead;
 264     ahead = SCM_CDR(hare);
 265     if (SCM_NCONSP(ahead)) return hare;
 266     hare = ahead;
 267     tortoise = SCM_CDR(tortoise);
 268   }
 269   while (! SCM_EQ_P (hare, tortoise));
 270   SCM_MISC_ERROR ("Circular structure in position 1: ~S", SCM_LIST1 (lst));
 271 }
 272 #undef FUNC_NAME
 273
 274 \f
 275 /* reversing lists */
 276
 277 SCM_DEFINE (scm_reverse, "reverse", 1, 0, 0,
 278             (SCM lst),
 279             "Return a new list that contains the elements of LST but in reverse order.")
 280 #define FUNC_NAME s_scm_reverse
 281 {
 282   SCM result = SCM_EOL;
 283   SCM tortoise = lst;
 284   SCM hare = lst;
 285
 286   do {
 287       if (SCM_NULLP(hare)) return result;
 288       SCM_ASSERT(SCM_CONSP(hare), lst, 1, FUNC_NAME);
 289       result = scm_cons (SCM_CAR (hare), result);
 290       hare = SCM_CDR (hare);
 291       if (SCM_NULLP(hare)) return result;
 292       SCM_ASSERT(SCM_CONSP(hare), lst, 1, FUNC_NAME);
 293       result = scm_cons (SCM_CAR (hare), result);
 294       hare = SCM_CDR (hare);
 295       tortoise = SCM_CDR (tortoise);
 296     }
 297   while (! SCM_EQ_P (hare, tortoise));
 298   SCM_MISC_ERROR ("Circular structure in position 1: ~S", SCM_LIST1 (lst));
 299 }
 300 #undef FUNC_NAME
 301
 302 SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0,
 303             (SCM lst, SCM new_tail),
 304             "A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r4rs,\n"
 305             "The Revised^4 Report on Scheme}).  The cdr of each cell in @var{lst} is\n"
 306             "modified to point to the previous list element.  Return a pointer to the\n"
 307             "head of the reversed list.\n\n"
 308             "Caveat: because the list is modified in place, the tail of the original\n"
 309             "list now becomes its head, and the head of the original list now becomes\n"
 310             "the tail.  Therefore, the @var{lst} symbol to which the head of the\n"
 311             "original list was bound now points to the tail.  To ensure that the head\n"
 312             "of the modified list is not lost, it is wise to save the return value of\n"
 313             "@code{reverse!}")
 314 #define FUNC_NAME s_scm_reverse_x
 315 {
 316   SCM_ASSERT (scm_ilength (lst) >= 0, lst, SCM_ARG1, FUNC_NAME);
 317   if (SCM_UNBNDP (new_tail))
 318     new_tail = SCM_EOL;
 319   else
 320     SCM_ASSERT (scm_ilength (new_tail) >= 0, new_tail, SCM_ARG2, FUNC_NAME);
 321
 322   while (SCM_NNULLP (lst))
 323     {
 324       SCM old_tail = SCM_CDR (lst);
 325       SCM_SETCDR (lst, new_tail);
 326       new_tail = lst;
 327       lst = old_tail;
 328     }
 329   return new_tail;
 330 }
 331 #undef FUNC_NAME
 332
 333
 334 \f
 335 /* indexing lists by element number */
 336
 337 SCM_DEFINE (scm_list_ref, "list-ref", 2, 0, 0,
 338            (SCM lst, SCM k),
 339             "Return the Kth element from list LST.")
 340 #define FUNC_NAME s_scm_list_ref
 341 {
 342   register long i;
 343   SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i);
 344   while (i-- > 0) {
 345     SCM_ASRTGO(SCM_CONSP(lst), erout);
 346     lst = SCM_CDR(lst);
 347   }
 348  erout:
 349   SCM_ASSERT(SCM_CONSP(lst),
 350              SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, FUNC_NAME);
 351   return SCM_CAR(lst);
 352 }
 353 #undef FUNC_NAME
 354
 355 SCM_DEFINE (scm_list_set_x, "list-set!", 3, 0, 0,
 356            (SCM lst, SCM k, SCM val),
 357             "Set the @var{k}th element of @var{lst} to @var{val}.")
 358 #define FUNC_NAME s_scm_list_set_x
 359 {
 360   register long i;
 361   SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i);
 362   while (i-- > 0) {
 363     SCM_ASRTGO(SCM_CONSP(lst), erout);
 364     lst = SCM_CDR(lst);
 365   }
 366  erout:
 367   SCM_ASSERT(SCM_CONSP(lst),
 368              SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, FUNC_NAME);
 369   SCM_SETCAR (lst, val);
 370   return val;
 371 }
 372 #undef FUNC_NAME
 373
 374
 375 SCM_REGISTER_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail);
 376
 377 SCM_DEFINE (scm_list_tail, "list-tail", 2, 0, 0,
 378            (SCM lst, SCM k),
 379             "Return the \"tail\" of @var{lst} beginning with its @var{k}th element.\n"
 380             "The first element of the list is considered to be element 0.\n\n"
 381             "@code{list-cdr-ref} and @code{list-tail} are identical.  It may help to\n"
 382             "think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list,\n"
 383             "or returning the results of cdring @var{k} times down @var{lst}.")
 384 #define FUNC_NAME s_scm_list_tail
 385 {
 386   register long i;
 387   SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i);
 388   while (i-- > 0) {
 389     SCM_VALIDATE_CONS (1,lst);
 390     lst = SCM_CDR(lst);
 391   }
 392   return lst;
 393 }
 394 #undef FUNC_NAME
 395
 396
 397 SCM_DEFINE (scm_list_cdr_set_x, "list-cdr-set!", 3, 0, 0,
 398            (SCM lst, SCM k, SCM val),
 399             "Set the @var{k}th cdr of @var{lst} to @var{val}.")
 400 #define FUNC_NAME s_scm_list_cdr_set_x
 401 {
 402   register long i;
 403   SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i);
 404   while (i-- > 0) {
 405     SCM_ASRTGO(SCM_CONSP(lst), erout);
 406     lst = SCM_CDR(lst);
 407   }
 408 erout:
 409   SCM_ASSERT(SCM_CONSP(lst),
 410              SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, FUNC_NAME);
 411   SCM_SETCDR (lst, val);
 412   return val;
 413 }
 414 #undef FUNC_NAME
 415
 416
 417 \f
 418 /* copying lists, perhaps partially */
 419
 420 SCM_DEFINE (scm_list_head, "list-head", 2, 0, 0,
 421            (SCM lst, SCM k),
 422             "Copy the first @var{k} elements from @var{lst} into a new list, and\n"
 423             "return it.")
 424 #define FUNC_NAME s_scm_list_head
 425 {
 426   SCM answer;
 427   SCM * pos;
 428   register long i;
 429
 430   SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i);
 431   answer = SCM_EOL;
 432   pos = &answer;
 433   while (i-- > 0)
 434     {
 435       SCM_VALIDATE_CONS (1,lst);
 436       *pos = scm_cons (SCM_CAR (lst), SCM_EOL);
 437       pos = SCM_CDRLOC (*pos);
 438       lst = SCM_CDR(lst);
 439     }
 440   return answer;
 441 }
 442 #undef FUNC_NAME
 443
 444
 445 SCM_DEFINE (scm_list_copy, "list-copy", 1, 0, 0,
 446             (SCM lst),
 447             "Return a (newly-created) copy of @var{lst}.")
 448 #define FUNC_NAME s_scm_list_copy
 449 {
 450   SCM newlst;
 451   SCM * fill_here;
 452   SCM from_here;
 453
 454   newlst = SCM_EOL;
 455   fill_here = &newlst;
 456   from_here = lst;
 457
 458   while (SCM_CONSP (from_here))
 459     {
 460       SCM c;
 461       c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here));
 462       *fill_here = c;
 463       fill_here = SCM_CDRLOC (c);
 464       from_here = SCM_CDR (from_here);
 465     }
 466   return newlst;
 467 }
 468 #undef FUNC_NAME
 469
 470 \f
 471 /* membership tests (memq, memv, etc.) */
 472
 473 SCM_DEFINE (scm_sloppy_memq, "sloppy-memq", 2, 0, 0,
 474             (SCM x, SCM lst),
 475             "This procedure behaves like @code{memq}, but does no type or error checking.\n"
 476             "Its use is recommended only in writing Guile internals,\n"
 477             "not for high-level Scheme programs.")
 478 #define FUNC_NAME s_scm_sloppy_memq
 479 {
 480   for(;  SCM_CONSP (lst);  lst = SCM_CDR(lst))
 481     {
 482       if (SCM_EQ_P (SCM_CAR (lst), x))
 483         return lst;
 484     }
 485   return lst;
 486 }
 487 #undef FUNC_NAME
 488
 489
 490 SCM_DEFINE (scm_sloppy_memv, "sloppy-memv", 2, 0, 0,
 491             (SCM x, SCM lst),
 492             "This procedure behaves like @code{memv}, but does no type or error checking.\n"
 493             "Its use is recommended only in writing Guile internals,\n"
 494             "not for high-level Scheme programs.")
 495 #define FUNC_NAME s_scm_sloppy_memv
 496 {
 497   for(;  SCM_CONSP (lst);  lst = SCM_CDR(lst))
 498     {
 499       if (! SCM_FALSEP (scm_eqv_p (SCM_CAR (lst), x)))
 500         return lst;
 501     }
 502   return lst;
 503 }
 504 #undef FUNC_NAME
 505
 506
 507 SCM_DEFINE (scm_sloppy_member, "sloppy-member", 2, 0, 0,
 508             (SCM x, SCM lst),
 509             "This procedure behaves like @code{member}, but does no type or error checking.\n"
 510             "Its use is recommended only in writing Guile internals,\n"
 511             "not for high-level Scheme programs.")
 512 #define FUNC_NAME s_scm_sloppy_member
 513 {
 514   for(;  SCM_CONSP (lst);  lst = SCM_CDR(lst))
 515     {
 516       if (! SCM_FALSEP (scm_equal_p (SCM_CAR (lst), x)))
 517         return lst;
 518     }
 519   return lst;
 520 }
 521 #undef FUNC_NAME
 522
 523
 524
 525 SCM_DEFINE (scm_memq, "memq", 2, 0, 0,
 526            (SCM x, SCM lst),
 527             "Return the first sublist of LST whose car is `eq?' to X\n"
 528             "where the sublists of LST are the non-empty lists returned\n"
 529             "by `(list-tail LST K)' for K less than the length of LST.  If\n"
 530             "X does not occur in LST, then `#f' (not the empty list) is\n"
 531             "returned.")
 532 #define FUNC_NAME s_scm_memq
 533 {
 534   SCM answer;
 535   SCM_VALIDATE_LIST (2,lst);
 536   answer = scm_sloppy_memq (x, lst);
 537   return (SCM_NULLP (answer)) ? SCM_BOOL_F : answer;
 538 }
 539 #undef FUNC_NAME
 540
 541
 542
 543 SCM_DEFINE (scm_memv, "memv", 2, 0, 0,
 544            (SCM x, SCM lst),
 545             "Return the first sublist of LST whose car is `eqv?' to X\n"
 546             "where the sublists of LST are the non-empty lists returned\n"
 547             "by `(list-tail LST K)' for K less than the length of LST.  If\n"
 548             "X does not occur in LST, then `#f' (not the empty list) is\n"
 549             "returned.")
 550 #define FUNC_NAME s_scm_memv
 551 {
 552   SCM answer;
 553   SCM_VALIDATE_LIST (2,lst);
 554   answer = scm_sloppy_memv (x, lst);
 555   return (SCM_NULLP (answer)) ? SCM_BOOL_F : answer;
 556 }
 557 #undef FUNC_NAME
 558
 559
 560 SCM_DEFINE (scm_member, "member", 2, 0, 0,
 561            (SCM x, SCM lst),
 562             "Return the first sublist of LST whose car is `equal?' to X\n"
 563             "where the sublists of LST are the non-empty lists returned\n"
 564             "by `(list-tail LST K)' for K less than the length of LST.  If\n"
 565             "X does not occur in LST, then `#f' (not the empty list) is\n"
 566             "returned.")
 567 #define FUNC_NAME s_scm_member
 568 {
 569   SCM answer;
 570   SCM_VALIDATE_LIST (2,lst);
 571   answer = scm_sloppy_member (x, lst);
 572   return (SCM_NULLP (answer)) ? SCM_BOOL_F : answer;
 573 }
 574 #undef FUNC_NAME
 575
 576
 577 \f
 578 /* deleting elements from a list (delq, etc.) */
 579
 580 SCM_DEFINE (scm_delq_x, "delq!", 2, 0, 0,
 581            (SCM item, SCM lst),
 582             "@deffnx primitive delv! item lst\n"
 583             "@deffnx primitive delete! item lst\n"
 584             "These procedures are destructive versions of @code{delq}, @code{delv}\n"
 585             "and @code{delete}: they modify the pointers in the existing @var{lst}\n"
 586             "rather than creating a new list.  Caveat evaluator: Like other\n"
 587             "destructive list functions, these functions cannot modify the binding of\n"
 588             "@var{lst}, and so cannot be used to delete the first element of\n"
 589             "@var{lst} destructively.")
 590 #define FUNC_NAME s_scm_delq_x
 591 {
 592   SCM walk;
 593   SCM *prev;
 594
 595   for (prev = &lst, walk = lst;
 596        SCM_CONSP (walk);
 597        walk = SCM_CDR (walk))
 598     {
 599       if (SCM_EQ_P (SCM_CAR (walk), item))
 600         *prev = SCM_CDR (walk);
 601       else
 602         prev = SCM_CDRLOC (walk);
 603     }
 604
 605   return lst;
 606 }
 607 #undef FUNC_NAME
 608
 609
 610 SCM_DEFINE (scm_delv_x, "delv!", 2, 0, 0,
 611            (SCM item, SCM lst),
 612             "Destructively remove all elements from LST that are `eqv?' to ITEM.")
 613 #define FUNC_NAME s_scm_delv_x
 614 {
 615   SCM walk;
 616   SCM *prev;
 617
 618   for (prev = &lst, walk = lst;
 619        SCM_CONSP (walk);
 620        walk = SCM_CDR (walk))
 621     {
 622       if (! SCM_FALSEP (scm_eqv_p (SCM_CAR (walk), item)))
 623         *prev = SCM_CDR (walk);
 624       else
 625         prev = SCM_CDRLOC (walk);
 626     }
 627
 628   return lst;
 629 }
 630 #undef FUNC_NAME
 631
 632
 633
 634 SCM_DEFINE (scm_delete_x, "delete!", 2, 0, 0,
 635            (SCM item, SCM lst),
 636             "Destructively remove all elements from LST that are `equal?' to ITEM.")
 637 #define FUNC_NAME s_scm_delete_x
 638 {
 639   SCM walk;
 640   SCM *prev;
 641
 642   for (prev = &lst, walk = lst;
 643        SCM_CONSP (walk);
 644        walk = SCM_CDR (walk))
 645     {
 646       if (! SCM_FALSEP (scm_equal_p (SCM_CAR (walk), item)))
 647         *prev = SCM_CDR (walk);
 648       else
 649         prev = SCM_CDRLOC (walk);
 650     }
 651
 652   return lst;
 653 }
 654 #undef FUNC_NAME
 655
 656
 657 \f
 658
 659
 660 SCM_DEFINE (scm_delq, "delq", 2, 0, 0,
 661             (SCM item, SCM lst),
 662             "Return a newly-created copy of @var{lst} with elements `eq?' to @var{item} removed.\n"
 663             "This procedure mirrors @code{memq}:\n"
 664             "@code{delq} compares elements of @var{lst} against @var{item} with\n"
 665             "@code{eq?}.")
 666 #define FUNC_NAME s_scm_delq
 667 {
 668   SCM copy = scm_list_copy (lst);
 669   return scm_delq_x (item, copy);
 670 }
 671 #undef FUNC_NAME
 672
 673 SCM_DEFINE (scm_delv, "delv", 2, 0, 0,
 674             (SCM item, SCM lst),
 675             "Return a newly-created copy of @var{lst} with elements `eqv?' to @var{item} removed.\n"
 676             "This procedure mirrors @code{memv}:\n"
 677             "@code{delv} compares elements of @var{lst} against @var{item} with\n"
 678             "@code{eqv?}.")
 679 #define FUNC_NAME s_scm_delv
 680 {
 681   SCM copy = scm_list_copy (lst);
 682   return scm_delv_x (item, copy);
 683 }
 684 #undef FUNC_NAME
 685
 686 SCM_DEFINE (scm_delete, "delete", 2, 0, 0,
 687             (SCM item, SCM lst),
 688             "Return a newly-created copy of @var{lst} with elements `equal?' to @var{item} removed.\n"
 689             "This procedure mirrors @code{member}:\n"
 690             "@code{delete} compares elements of @var{lst} against @var{item} with\n"
 691             "@code{equal?}.")
 692 #define FUNC_NAME s_scm_delete
 693 {
 694   SCM copy = scm_list_copy (lst);
 695   return scm_delete_x (item, copy);
 696 }
 697 #undef FUNC_NAME
 698
 699
 700 SCM_DEFINE (scm_delq1_x, "delq1!", 2, 0, 0,
 701            (SCM item, SCM lst),
 702             "Like `delq!', but only deletes the first occurrence of ITEM from LST.\n"
 703             "Tests for equality using `eq?'.  See also `delv1!' and `delete1!'.")
 704 #define FUNC_NAME s_scm_delq1_x
 705 {
 706   SCM walk;
 707   SCM *prev;
 708
 709   for (prev = &lst, walk = lst;
 710        SCM_CONSP (walk);
 711        walk = SCM_CDR (walk))
 712     {
 713       if (SCM_EQ_P (SCM_CAR (walk), item))
 714         {
 715           *prev = SCM_CDR (walk);
 716           break;
 717         }
 718       else
 719         prev = SCM_CDRLOC (walk);
 720     }
 721
 722   return lst;
 723 }
 724 #undef FUNC_NAME
 725
 726
 727 SCM_DEFINE (scm_delv1_x, "delv1!", 2, 0, 0,
 728             (SCM item, SCM lst),
 729             "Like `delv!', but only deletes the first occurrence of ITEM from LST.\n"
 730             "Tests for equality using `eqv?'.  See also `delq1!' and `delete1!'.")
 731 #define FUNC_NAME s_scm_delv1_x
 732 {
 733   SCM walk;
 734   SCM *prev;
 735
 736   for (prev = &lst, walk = lst;
 737        SCM_CONSP (walk);
 738        walk = SCM_CDR (walk))
 739     {
 740       if (! SCM_FALSEP (scm_eqv_p (SCM_CAR (walk), item)))
 741         {
 742           *prev = SCM_CDR (walk);
 743           break;
 744         }
 745       else
 746         prev = SCM_CDRLOC (walk);
 747     }
 748
 749   return lst;
 750 }
 751 #undef FUNC_NAME
 752
 753
 754 SCM_DEFINE (scm_delete1_x, "delete1!", 2, 0, 0,
 755             (SCM item, SCM lst),
 756             "Like `delete!', but only deletes the first occurrence of ITEM from LST.\n"
 757             "Tests for equality using `equal?'.  See also `delq1!' and `delv1!'.")
 758 #define FUNC_NAME s_scm_delete1_x
 759 {
 760   SCM walk;
 761   SCM *prev;
 762
 763   for (prev = &lst, walk = lst;
 764        SCM_CONSP (walk);
 765        walk = SCM_CDR (walk))
 766     {
 767       if (! SCM_FALSEP (scm_equal_p (SCM_CAR (walk), item)))
 768         {
 769           *prev = SCM_CDR (walk);
 770           break;
 771         }
 772       else
 773         prev = SCM_CDRLOC (walk);
 774     }
 775
 776   return lst;
 777 }
 778 #undef FUNC_NAME
 779
 780
 781 \f
 782 void
 783 scm_init_list ()
 784 {
 785 #include "libguile/list.x"
 786 }
 787
 788 /*
 789   Local Variables:
 790   c-file-style: "gnu"
 791   End:
 792 */