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