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 "_scm.h"
  48 #include "eq.h"
  49
  50 #include "scm_validate.h"
  51 #include "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_P won't help us deal with varargs here.  */
  65 #ifdef __STDC__
  66 SCM
  67 scm_listify (SCM elt, ...)
  68 #else
  69 SCM
  70 scm_listify (elt, va_alist)
  71      SCM elt;
  72      va_dcl
  73 #endif
  74 {
  75   va_list foo;
  76   SCM answer;
  77   SCM *pos;
  78
  79   var_start (foo, elt);
  80   answer = SCM_EOL;
  81   pos = &answer;
  82   while (elt != SCM_UNDEFINED)
  83     {
  84       *pos = scm_cons (elt, SCM_EOL);
  85       pos = SCM_CDRLOC (*pos);
  86       elt = va_arg (foo, SCM);
  87     }
  88   return answer;
  89 }
  90
  91
  92 GUILE_PROC(scm_list, "list", 0, 0, 1,
  93            (SCM objs),
  94 "")
  95 #define FUNC_NAME s_scm_list
  96 {
  97   return objs;
  98 }
  99 #undef FUNC_NAME
 100
 101
 102 GUILE_PROC (scm_list_star, "list*", 1, 0, 1,
 103             (SCM arg, SCM rest),
 104 "")
 105 #define FUNC_NAME s_scm_list_star
 106 {
 107   if (SCM_NIMP (rest))
 108     {
 109       SCM prev = arg = scm_cons (arg, rest);
 110       while (SCM_NIMP (SCM_CDR (rest)))
 111         {
 112           prev = rest;
 113           rest = SCM_CDR (rest);
 114         }
 115       SCM_SETCDR (prev, SCM_CAR (rest));
 116     }
 117   return arg;
 118 }
 119 #undef FUNC_NAME
 120
 121
 122 \f
 123 /* general questions about lists --- null?, list?, length, etc.  */
 124
 125 GUILE_PROC(scm_null_p, "null?", 1, 0, 0,
 126            (SCM x),
 127 "")
 128 #define FUNC_NAME s_scm_null_p
 129 {
 130   return SCM_BOOL(SCM_NULLP(x));
 131 }
 132 #undef FUNC_NAME
 133
 134 GUILE_PROC(scm_list_p, "list?", 1, 0, 0,
 135            (SCM x),
 136 "")
 137 #define FUNC_NAME s_scm_list_p
 138 {
 139   return SCM_BOOL(scm_ilength(x)>=0);
 140 }
 141 #undef FUNC_NAME
 142
 143
 144 /* Return the length of SX, or -1 if it's not a proper list.
 145    This uses the "tortoise and hare" algorithm to detect "infinitely
 146    long" lists (i.e. lists with cycles in their cdrs), and returns -1
 147    if it does find one.  */
 148 long
 149 scm_ilength(SCM sx)
 150 {
 151   register long i = 0;
 152   register SCM tortoise = sx;
 153   register SCM hare = sx;
 154
 155   do {
 156     if (SCM_IMP(hare)) return SCM_NULLP(hare) ? i : -1;
 157     if (SCM_NCONSP(hare)) return -1;
 158     hare = SCM_CDR(hare);
 159     i++;
 160     if (SCM_IMP(hare)) return SCM_NULLP(hare) ? i : -1;
 161     if (SCM_NCONSP(hare)) return -1;
 162     hare = SCM_CDR(hare);
 163     i++;
 164     /* For every two steps the hare takes, the tortoise takes one.  */
 165     tortoise = SCM_CDR(tortoise);
 166   }
 167   while (hare != tortoise);
 168
 169   /* If the tortoise ever catches the hare, then the list must contain
 170      a cycle.  */
 171   return -1;
 172 }
 173
 174 GUILE_PROC(scm_length, "length", 1, 0, 0,
 175            (SCM lst),
 176 "")
 177 #define FUNC_NAME s_scm_length
 178 {
 179   int i;
 180   SCM_VALIDATE_LIST_COPYLEN(1,lst,i);
 181   return SCM_MAKINUM (i);
 182 }
 183 #undef FUNC_NAME
 184
 185
 186 \f
 187 /* appending lists */
 188
 189 GUILE_PROC (scm_append, "append", 0, 0, 1,
 190             (SCM args),
 191 "A destructive version of @code{append} (@pxref{Pairs and Lists,,,r4rs,
 192 The Revised^4 Report on Scheme}).  The cdr field of each list's final
 193 pair is changed to point to the head of the next list, so no consing is
 194 performed.  Return a pointer to the mutated list.")
 195 #define FUNC_NAME s_scm_append
 196 {
 197   SCM res = SCM_EOL;
 198   SCM *lloc = &res, arg;
 199   if (SCM_IMP(args)) {
 200     SCM_VALIDATE_NULL(SCM_ARGn, args);
 201     return res;
 202   }
 203   SCM_VALIDATE_CONS(SCM_ARGn, args);
 204   while (1) {
 205     arg = SCM_CAR(args);
 206     args = SCM_CDR(args);
 207     if (SCM_IMP(args)) {
 208       *lloc = arg;
 209       SCM_VALIDATE_NULL(SCM_ARGn, args);
 210       return res;
 211     }
 212     SCM_VALIDATE_CONS(SCM_ARGn, args);
 213     for(;SCM_NIMP(arg);arg = SCM_CDR(arg)) {
 214       SCM_VALIDATE_CONS(SCM_ARGn, arg);
 215       *lloc = scm_cons(SCM_CAR(arg), SCM_EOL);
 216       lloc = SCM_CDRLOC(*lloc);
 217     }
 218     SCM_VALIDATE_NULL(SCM_ARGn, arg);
 219   }
 220 }
 221 #undef FUNC_NAME
 222
 223
 224 GUILE_PROC (scm_append_x, "append!", 0, 0, 1,
 225             (SCM args),
 226 "")
 227 #define FUNC_NAME s_scm_append_x
 228 {
 229   SCM arg;
 230  tail:
 231   if (SCM_NULLP(args)) return SCM_EOL;
 232   arg = SCM_CAR(args);
 233   args = SCM_CDR(args);
 234   if (SCM_NULLP(args)) return arg;
 235   if (SCM_NULLP(arg)) goto tail;
 236   SCM_VALIDATE_NIMCONS(SCM_ARG1,arg);
 237   SCM_SETCDR (scm_last_pair (arg), scm_append_x (args));
 238   return arg;
 239 }
 240 #undef FUNC_NAME
 241
 242
 243 GUILE_PROC(scm_last_pair, "last-pair", 1, 0, 0,
 244            (SCM sx),
 245 "Return a pointer to the last pair in @var{lst}, signalling an error if
 246 @var{lst} is circular.")
 247 #define FUNC_NAME s_scm_last_pair
 248 {
 249   register SCM res = sx;
 250   register SCM x;
 251
 252   if (SCM_NULLP (sx))
 253     return SCM_EOL;
 254
 255   SCM_VALIDATE_NIMCONS(SCM_ARG1,res);
 256   while (!0) {
 257     x = SCM_CDR(res);
 258     if (SCM_IMP(x) || SCM_NCONSP(x)) return res;
 259     res = x;
 260     x = SCM_CDR(res);
 261     if (SCM_IMP(x) || SCM_NCONSP(x)) return res;
 262     res = x;
 263     sx = SCM_CDR(sx);
 264     SCM_ASSERT(x != sx, sx, SCM_ARG1, FUNC_NAME);
 265   }
 266 }
 267 #undef FUNC_NAME
 268
 269 \f
 270 /* reversing lists */
 271
 272 GUILE_PROC (scm_reverse, "reverse", 1, 0, 0,
 273             (SCM ls),
 274 "A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r4rs,
 275 The Revised^4 Report on Scheme}).  The cdr of each cell in @var{lst} is
 276 modified to point to the previous list element.  Return a pointer to the
 277 head of the reversed list.
 278
 279 Caveat: because the list is modified in place, the tail of the original
 280 list now becomes its head, and the head of the original list now becomes
 281 the tail.  Therefore, the @var{lst} symbol to which the head of the
 282 original list was bound now points to the tail.  To ensure that the head
 283 of the modified list is not lost, it is wise to save the return value of
 284 @code{reverse!}")
 285 #define FUNC_NAME s_scm_reverse
 286 {
 287   SCM res = SCM_EOL;
 288   SCM p = ls, t = ls;
 289   while (SCM_NIMP (p))
 290     {
 291       SCM_VALIDATE_CONS(1,ls);
 292       res = scm_cons (SCM_CAR (p), res);
 293       p = SCM_CDR (p);
 294       if (SCM_IMP (p))
 295         break;
 296       SCM_VALIDATE_CONS(1,ls);
 297       res = scm_cons (SCM_CAR (p), res);
 298       p = SCM_CDR (p);
 299       t = SCM_CDR (t);
 300       if (t == p)
 301         scm_misc_error (FUNC_NAME, "Circular structure: %S", SCM_LIST1 (ls));
 302     }
 303   ls = p;
 304   SCM_VALIDATE_NULL(1,ls);
 305   return res;
 306 }
 307 #undef FUNC_NAME
 308
 309 GUILE_PROC (scm_reverse_x, "reverse!", 1, 1, 0,
 310             (SCM ls, SCM new_tail),
 311 "")
 312 #define FUNC_NAME s_scm_reverse_x
 313 {
 314   SCM old_tail;
 315   SCM_ASSERT (scm_ilength (ls) >= 0, ls, SCM_ARG1, FUNC_NAME);
 316   if (SCM_UNBNDP (new_tail))
 317     new_tail = SCM_EOL;
 318   else
 319     SCM_ASSERT (scm_ilength (new_tail) >= 0, new_tail, SCM_ARG2, FUNC_NAME);
 320
 321   while (SCM_NIMP (ls))
 322     {
 323       old_tail = SCM_CDR (ls);
 324       SCM_SETCDR (ls, new_tail);
 325       new_tail = ls;
 326       ls = old_tail;
 327     }
 328   return new_tail;
 329 }
 330 #undef FUNC_NAME
 331
 332
 333 \f
 334 /* indexing lists by element number */
 335
 336 GUILE_PROC(scm_list_ref, "list-ref", 2, 0, 0,
 337            (SCM lst, SCM k),
 338 "")
 339 #define FUNC_NAME s_scm_list_ref
 340 {
 341   register long i;
 342   SCM_VALIDATE_INT_MIN_COPY(2,k,0,i);
 343   while (i-- > 0) {
 344     SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout);
 345     lst = SCM_CDR(lst);
 346   }
 347  erout:
 348   SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst),
 349              SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, FUNC_NAME);
 350   return SCM_CAR(lst);
 351 }
 352 #undef FUNC_NAME
 353
 354 GUILE_PROC(scm_list_set_x, "list-set!", 3, 0, 0,
 355            (SCM lst, SCM k, SCM val),
 356 "Set the @var{k}th element of @var{lst} to @var{val}.")
 357 #define FUNC_NAME s_scm_list_set_x
 358 {
 359   register long i;
 360   SCM_VALIDATE_INT_MIN_COPY(2,k,0,i);
 361   while (i-- > 0) {
 362     SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout);
 363     lst = SCM_CDR(lst);
 364   }
 365  erout:
 366   SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst),
 367              SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, FUNC_NAME);
 368   SCM_SETCAR (lst, val);
 369   return val;
 370 }
 371 #undef FUNC_NAME
 372
 373
 374 SCM_REGISTER_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail);
 375
 376 GUILE_PROC(scm_list_tail, "list-tail", 2, 0, 0,
 377            (SCM lst, SCM k),
 378 "Return the \"tail\" of @var{lst} beginning with its @var{k}th element.
 379 The first element of the list is considered to be element 0.
 380
 381 @code{list-cdr-ref} and @code{list-tail} are identical.  It may help to
 382 think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list,
 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_INT_MIN_COPY(2,k,0,i);
 388   while (i-- > 0) {
 389     SCM_VALIDATE_NIMCONS(1,lst);
 390     lst = SCM_CDR(lst);
 391   }
 392   return lst;
 393 }
 394 #undef FUNC_NAME
 395
 396
 397 GUILE_PROC(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_INT_MIN_COPY(2,k,0,i);
 404   while (i-- > 0) {
 405     SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout);
 406     lst = SCM_CDR(lst);
 407   }
 408 erout:
 409   SCM_ASSERT(SCM_NIMP(lst) && 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 GUILE_PROC(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
 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_INT_MIN_COPY(2,k,0,i);
 431   answer = SCM_EOL;
 432   pos = &answer;
 433   while (i-- > 0)
 434     {
 435       SCM_VALIDATE_NIMCONS(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 GUILE_PROC (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_NIMP (from_here) && 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 GUILE_PROC (scm_sloppy_memq, "sloppy-memq", 2, 0, 0,
 474             (SCM x, SCM lst),
 475 "@deffnx primitive sloppy-memv
 476 @deffnx primitive sloppy-member
 477 These procedures behave like @code{memq}, @code{memv} and @code{member}
 478 (@pxref{Pairs and Lists,,,r4rs, The Revised^4 Report on Scheme}), but do
 479 not perform any type or error checking.  Their use is recommended only
 480 in writing Guile internals, not for high-level Scheme programs.")
 481 #define FUNC_NAME s_scm_sloppy_memq
 482 {
 483   for(;  SCM_NIMP(lst) && SCM_CONSP (lst);  lst = SCM_CDR(lst))
 484     {
 485       if (SCM_CAR(lst)==x)
 486         return lst;
 487     }
 488   return lst;
 489 }
 490 #undef FUNC_NAME
 491
 492
 493 GUILE_PROC (scm_sloppy_memv, "sloppy-memv", 2, 0, 0,
 494             (SCM x, SCM lst),
 495 "")
 496 #define FUNC_NAME s_scm_sloppy_memv
 497 {
 498   for(;  SCM_NIMP(lst) && SCM_CONSP (lst);  lst = SCM_CDR(lst))
 499     {
 500       if (SCM_BOOL_F != scm_eqv_p (SCM_CAR(lst), x))
 501         return lst;
 502     }
 503   return lst;
 504 }
 505 #undef FUNC_NAME
 506
 507
 508 GUILE_PROC (scm_sloppy_member, "sloppy-member", 2, 0, 0,
 509             (SCM x, SCM lst),
 510 "")
 511 #define FUNC_NAME s_scm_sloppy_member
 512 {
 513   for(;  SCM_NIMP(lst) && SCM_CONSP (lst);  lst = SCM_CDR(lst))
 514     {
 515       if (SCM_BOOL_F != scm_equal_p (SCM_CAR(lst), x))
 516         return lst;
 517     }
 518   return lst;
 519 }
 520 #undef FUNC_NAME
 521
 522
 523
 524 GUILE_PROC(scm_memq, "memq", 2, 0, 0,
 525            (SCM x, SCM lst),
 526 "")
 527 #define FUNC_NAME s_scm_memq
 528 {
 529   SCM answer;
 530   SCM_VALIDATE_LIST(2,lst);
 531   answer = scm_sloppy_memq (x, lst);
 532   return (answer == SCM_EOL) ? SCM_BOOL_F : answer;
 533 }
 534 #undef FUNC_NAME
 535
 536
 537
 538 GUILE_PROC(scm_memv, "memv", 2, 0, 0,
 539            (SCM x, SCM lst),
 540 "")
 541 #define FUNC_NAME s_scm_memv
 542 {
 543   SCM answer;
 544   SCM_VALIDATE_LIST(2,lst);
 545   answer = scm_sloppy_memv (x, lst);
 546   return (answer == SCM_EOL) ? SCM_BOOL_F : answer;
 547 }
 548 #undef FUNC_NAME
 549
 550
 551 GUILE_PROC(scm_member, "member", 2, 0, 0,
 552            (SCM x, SCM lst),
 553 "")
 554 #define FUNC_NAME s_scm_member
 555 {
 556   SCM answer;
 557   SCM_VALIDATE_LIST(2,lst);
 558   answer = scm_sloppy_member (x, lst);
 559   return (answer == SCM_EOL) ? SCM_BOOL_F : answer;
 560 }
 561 #undef FUNC_NAME
 562
 563
 564 \f
 565 /* deleting elements from a list (delq, etc.) */
 566
 567 GUILE_PROC(scm_delq_x, "delq!", 2, 0, 0,
 568            (SCM item, SCM lst),
 569 "@deffnx primitive delv! item lst
 570 @deffnx primitive delete! item lst
 571 These procedures are destructive versions of @code{delq}, @code{delv}
 572 and @code{delete}: they modify the pointers in the existing @var{lst}
 573 rather than creating a new list.  Caveat evaluator: Like other
 574 destructive list functions, these functions cannot modify the binding of
 575 @var{lst}, and so cannot be used to delete the first element of
 576 @var{lst} destructively.")
 577 #define FUNC_NAME s_scm_delq_x
 578 {
 579   SCM walk;
 580   SCM *prev;
 581
 582   for (prev = &lst, walk = lst;
 583        SCM_NIMP (walk) && SCM_CONSP (walk);
 584        walk = SCM_CDR (walk))
 585     {
 586       if (SCM_CAR (walk) == item)
 587         *prev = SCM_CDR (walk);
 588       else
 589         prev = SCM_CDRLOC (walk);
 590     }
 591
 592   return lst;
 593 }
 594 #undef FUNC_NAME
 595
 596
 597 GUILE_PROC(scm_delv_x, "delv!", 2, 0, 0,
 598            (SCM item, SCM lst),
 599 "")
 600 #define FUNC_NAME s_scm_delv_x
 601 {
 602   SCM walk;
 603   SCM *prev;
 604
 605   for (prev = &lst, walk = lst;
 606        SCM_NIMP (walk) && SCM_CONSP (walk);
 607        walk = SCM_CDR (walk))
 608     {
 609       if (SCM_BOOL_F != scm_eqv_p (SCM_CAR (walk), item))
 610         *prev = SCM_CDR (walk);
 611       else
 612         prev = SCM_CDRLOC (walk);
 613     }
 614
 615   return lst;
 616 }
 617 #undef FUNC_NAME
 618
 619
 620
 621 GUILE_PROC(scm_delete_x, "delete!", 2, 0, 0,
 622            (SCM item, SCM lst),
 623 "")
 624 #define FUNC_NAME s_scm_delete_x
 625 {
 626   SCM walk;
 627   SCM *prev;
 628
 629   for (prev = &lst, walk = lst;
 630        SCM_NIMP (walk) && SCM_CONSP (walk);
 631        walk = SCM_CDR (walk))
 632     {
 633       if (SCM_BOOL_F != scm_equal_p (SCM_CAR (walk), item))
 634         *prev = SCM_CDR (walk);
 635       else
 636         prev = SCM_CDRLOC (walk);
 637     }
 638
 639   return lst;
 640 }
 641 #undef FUNC_NAME
 642
 643
 644 \f
 645
 646
 647 GUILE_PROC (scm_delq, "delq", 2, 0, 0,
 648             (SCM item, SCM lst),
 649 "@deffnx primitive delv item lst
 650 @deffnx primitive delete item lst
 651 Return a newly-created copy of @var{lst} with @var{item} removed.  These
 652 procedures mirror @code{memq}, @code{memv} and @code{member}:
 653 @code{delq} compares elements of @var{lst} against @var{item} with
 654 @code{eq?}, @code{delv} uses @code{eqv?} and @code{delete} uses @code{equal?}")
 655 #define FUNC_NAME s_scm_delq
 656 {
 657   SCM copy = scm_list_copy (lst);
 658   return scm_delq_x (item, copy);
 659 }
 660 #undef FUNC_NAME
 661
 662 GUILE_PROC (scm_delv, "delv", 2, 0, 0,
 663             (SCM item, SCM lst),
 664 "")
 665 #define FUNC_NAME s_scm_delv
 666 {
 667   SCM copy = scm_list_copy (lst);
 668   return scm_delv_x (item, copy);
 669 }
 670 #undef FUNC_NAME
 671
 672 GUILE_PROC (scm_delete, "delete", 2, 0, 0,
 673             (SCM item, SCM lst),
 674 "")
 675 #define FUNC_NAME s_scm_delete
 676 {
 677   SCM copy = scm_list_copy (lst);
 678   return scm_delete_x (item, copy);
 679 }
 680 #undef FUNC_NAME
 681
 682
 683 GUILE_PROC(scm_delq1_x, "delq1!", 2, 0, 0,
 684            (SCM item, SCM lst),
 685 "")
 686 #define FUNC_NAME s_scm_delq1_x
 687 {
 688   SCM walk;
 689   SCM *prev;
 690
 691   for (prev = &lst, walk = lst;
 692        SCM_NIMP (walk) && SCM_CONSP (walk);
 693        walk = SCM_CDR (walk))
 694     {
 695       if (SCM_CAR (walk) == item)
 696         {
 697           *prev = SCM_CDR (walk);
 698           break;
 699         }
 700       else
 701         prev = SCM_CDRLOC (walk);
 702     }
 703
 704   return lst;
 705 }
 706 #undef FUNC_NAME
 707
 708
 709 GUILE_PROC(scm_delv1_x, "delv1!", 2, 0, 0,
 710            (SCM item, SCM lst),
 711 "")
 712 #define FUNC_NAME s_scm_delv1_x
 713 {
 714   SCM walk;
 715   SCM *prev;
 716
 717   for (prev = &lst, walk = lst;
 718        SCM_NIMP (walk) && SCM_CONSP (walk);
 719        walk = SCM_CDR (walk))
 720     {
 721       if (SCM_BOOL_F != scm_eqv_p (SCM_CAR (walk), item))
 722         {
 723           *prev = SCM_CDR (walk);
 724           break;
 725         }
 726       else
 727         prev = SCM_CDRLOC (walk);
 728     }
 729
 730   return lst;
 731 }
 732 #undef FUNC_NAME
 733
 734
 735 GUILE_PROC(scm_delete1_x, "delete1!", 2, 0, 0,
 736            (SCM item, SCM lst),
 737 "")
 738 #define FUNC_NAME s_scm_delete1_x
 739 {
 740   SCM walk;
 741   SCM *prev;
 742
 743   for (prev = &lst, walk = lst;
 744        SCM_NIMP (walk) && SCM_CONSP (walk);
 745        walk = SCM_CDR (walk))
 746     {
 747       if (SCM_BOOL_F != scm_equal_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 \f
 762 void
 763 scm_init_list ()
 764 {
 765 #include "list.x"
 766 }