libguile/srfi-1.c

   1 /* srfi-1.c --- SRFI-1 procedures for Guile
   2  *
   3  * Copyright (C) 1995-1997, 2000-2003, 2005, 2006, 2008-2011,
   4  *   2014 Free Software Foundation, Inc.
   5  *
   6  * This library is free software; you can redistribute it and/or
   7  * modify it under the terms of the GNU Lesser General Public License
   8  * as published by the Free Software Foundation; either version 3 of
   9  * the License, or (at your option) any later version.
  10  *
  11  * This library is distributed in the hope that it will be useful, but
  12  * WITHOUT ANY WARRANTY; without even the implied warranty of
  13  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14  * Lesser General Public License for more details.
  15  *
  16  * You should have received a copy of the GNU Lesser General Public
  17  * License along with this library; if not, write to the Free Software
  18  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  19  * 02110-1301 USA
  20  */
  21
  22 \f
  23 #ifdef HAVE_CONFIG_H
  24 # include <config.h>
  25 #endif
  26
  27 #include "libguile/_scm.h"
  28 #include "libguile/eq.h"
  29
  30 #include "libguile/validate.h"
  31 #include "libguile/list.h"
  32 #include "libguile/eval.h"
  33 #include "libguile/srfi-1.h"
  34
  35 #include <stdarg.h>
  36
  37
  38 /* The intent of this file was to gradually replace those Scheme
  39  * procedures in srfi-1.scm that extend core primitive procedures,
  40  * so that using srfi-1 wouldn't have performance penalties.
  41  *
  42  * However, we now prefer to write these procedures in Scheme, let the compiler
  43  * optimize them, and have the VM execute them efficiently.
  44  */
  45
  46
  47 static SCM
  48 equal_trampoline (SCM proc, SCM arg1, SCM arg2)
  49 {
  50   return scm_equal_p (arg1, arg2);
  51 }
  52
  53 /* list_copy_part() copies the first COUNT cells of LST, puts the result at
  54    *dst, and returns the SCM_CDRLOC of the last cell in that new list.
  55
  56    This function is designed to be careful about LST possibly having changed
  57    in between the caller deciding what to copy, and the copy actually being
  58    done here.  The COUNT ensures we terminate if LST has become circular,
  59    SCM_VALIDATE_CONS guards against a cdr in the list changed to some
  60    non-pair object.  */
  61
  62 #include <stdio.h>
  63 static SCM *
  64 list_copy_part (SCM lst, int count, SCM *dst)
  65 #define FUNC_NAME "list_copy_part"
  66 {
  67   SCM c;
  68   for ( ; count > 0; count--)
  69     {
  70       SCM_VALIDATE_CONS (SCM_ARGn, lst);
  71       c = scm_cons (SCM_CAR (lst), SCM_EOL);
  72       *dst = c;
  73       dst = SCM_CDRLOC (c);
  74       lst = SCM_CDR (lst);
  75     }
  76   return dst;
  77 }
  78 #undef FUNC_NAME
  79
  80
  81 SCM_DEFINE (scm_srfi1_append_reverse, "append-reverse", 2, 0, 0,
  82             (SCM revhead, SCM tail),
  83             "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
  84             "result.  This is equivalent to @code{(append (reverse\n"
  85             "@var{rev-head}) @var{tail})}, but its implementation is more\n"
  86             "efficient.\n"
  87             "\n"
  88             "@example\n"
  89             "(append-reverse '(1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
  90             "@end example")
  91 #define FUNC_NAME s_scm_srfi1_append_reverse
  92 {
  93   while (scm_is_pair (revhead))
  94     {
  95       /* copy first element of revhead onto front of tail */
  96       tail = scm_cons (SCM_CAR (revhead), tail);
  97       revhead = SCM_CDR (revhead);
  98     }
  99   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead), revhead, SCM_ARG1, FUNC_NAME,
 100                    "list");
 101   return tail;
 102 }
 103 #undef FUNC_NAME
 104
 105
 106 SCM_DEFINE (scm_srfi1_append_reverse_x, "append-reverse!", 2, 0, 0,
 107             (SCM revhead, SCM tail),
 108             "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
 109             "result.  This is equivalent to @code{(append! (reverse!\n"
 110             "@var{rev-head}) @var{tail})}, but its implementation is more\n"
 111             "efficient.\n"
 112             "\n"
 113             "@example\n"
 114             "(append-reverse! (list 1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
 115             "@end example\n"
 116             "\n"
 117             "@var{rev-head} may be modified in order to produce the result.")
 118 #define FUNC_NAME s_scm_srfi1_append_reverse_x
 119 {
 120   SCM newtail;
 121
 122   while (scm_is_pair (revhead))
 123     {
 124       /* take the first cons cell from revhead */
 125       newtail = revhead;
 126       revhead = SCM_CDR (revhead);
 127
 128       /* make it the new start of tail, appending the previous */
 129       SCM_SETCDR (newtail, tail);
 130       tail = newtail;
 131     }
 132   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead), revhead, SCM_ARG1, FUNC_NAME,
 133                    "list");
 134   return tail;
 135 }
 136 #undef FUNC_NAME
 137
 138 SCM_DEFINE (scm_srfi1_concatenate, "concatenate", 1, 0, 0,
 139             (SCM lstlst),
 140             "Construct a list by appending all lists in @var{lstlst}.\n"
 141             "\n"
 142             "@code{concatenate} is the same as @code{(apply append\n"
 143             "@var{lstlst})}.  It exists because some Scheme implementations\n"
 144             "have a limit on the number of arguments a function takes, which\n"
 145             "the @code{apply} might exceed.  In Guile there is no such\n"
 146             "limit.")
 147 #define FUNC_NAME s_scm_srfi1_concatenate
 148 {
 149   SCM_VALIDATE_LIST (SCM_ARG1, lstlst);
 150   return scm_append (lstlst);
 151 }
 152 #undef FUNC_NAME
 153
 154
 155 SCM_DEFINE (scm_srfi1_concatenate_x, "concatenate!", 1, 0, 0,
 156             (SCM lstlst),
 157             "Construct a list by appending all lists in @var{lstlst}.  Those\n"
 158             "lists may be modified to produce the result.\n"
 159             "\n"
 160             "@code{concatenate!} is the same as @code{(apply append!\n"
 161             "@var{lstlst})}.  It exists because some Scheme implementations\n"
 162             "have a limit on the number of arguments a function takes, which\n"
 163             "the @code{apply} might exceed.  In Guile there is no such\n"
 164             "limit.")
 165 #define FUNC_NAME s_scm_srfi1_concatenate_x
 166 {
 167   SCM_VALIDATE_LIST (SCM_ARG1, lstlst);
 168   return scm_append_x (lstlst);
 169 }
 170 #undef FUNC_NAME
 171
 172
 173 SCM_DEFINE (scm_srfi1_count, "count", 2, 0, 1,
 174             (SCM pred, SCM list1, SCM rest),
 175             "Return a count of the number of times @var{pred} returns true\n"
 176             "when called on elements from the given lists.\n"
 177             "\n"
 178             "@var{pred} is called with @var{N} parameters @code{(@var{pred}\n"
 179             "@var{elem1} @dots{} @var{elemN})}, each element being from the\n"
 180             "corresponding @var{list1} @dots{} @var{lstN}.  The first call is\n"
 181             "with the first element of each list, the second with the second\n"
 182             "element from each, and so on.\n"
 183             "\n"
 184             "Counting stops when the end of the shortest list is reached.\n"
 185             "At least one list must be non-circular.")
 186 #define FUNC_NAME s_scm_srfi1_count
 187 {
 188   long  count;
 189   SCM   lst;
 190   int   argnum;
 191   SCM_VALIDATE_REST_ARGUMENT (rest);
 192
 193   count = 0;
 194
 195   if (scm_is_null (rest))
 196     {
 197       /* one list */
 198       SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
 199
 200       for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
 201         count += scm_is_true (scm_call_1 (pred, SCM_CAR (list1)));
 202
 203       /* check below that list1 is a proper list, and done */
 204     end_list1:
 205       lst = list1;
 206       argnum = 2;
 207     }
 208   else if (scm_is_pair (rest) && scm_is_null (SCM_CDR (rest)))
 209     {
 210       /* two lists */
 211       SCM list2;
 212
 213       SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
 214
 215       list2 = SCM_CAR (rest);
 216       for (;;)
 217         {
 218           if (! scm_is_pair (list1))
 219             goto end_list1;
 220           if (! scm_is_pair (list2))
 221             {
 222               lst = list2;
 223               argnum = 3;
 224               break;
 225             }
 226           count += scm_is_true (scm_call_2
 227                                 (pred, SCM_CAR (list1), SCM_CAR (list2)));
 228           list1 = SCM_CDR (list1);
 229           list2 = SCM_CDR (list2);
 230         }
 231     }
 232   else
 233     {
 234       /* three or more lists */
 235       SCM  vec, args, a;
 236       size_t  len, i;
 237
 238       /* vec is the list arguments */
 239       vec = scm_vector (scm_cons (list1, rest));
 240       len = SCM_SIMPLE_VECTOR_LENGTH (vec);
 241
 242       /* args is the argument list to pass to pred, same length as vec,
 243          re-used for each call */
 244       args = scm_make_list (SCM_I_MAKINUM (len), SCM_UNDEFINED);
 245
 246       for (;;)
 247         {
 248           /* first elem of each list in vec into args, and step those
 249              vec entries onto their next element */
 250           for (i = 0, a = args, argnum = 2;
 251                i < len;
 252                i++, a = SCM_CDR (a), argnum++)
 253             {
 254               lst = SCM_SIMPLE_VECTOR_REF (vec, i);  /* list argument */
 255               if (! scm_is_pair (lst))
 256                 goto check_lst_and_done;
 257               SCM_SETCAR (a, SCM_CAR (lst));  /* arg for pred */
 258               SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst));  /* rest of lst */
 259             }
 260
 261           count += scm_is_true (scm_apply (pred, args, SCM_EOL));
 262         }
 263     }
 264
 265  check_lst_and_done:
 266   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
 267   return scm_from_long (count);
 268 }
 269 #undef FUNC_NAME
 270
 271
 272 SCM_DEFINE (scm_srfi1_delete, "delete", 2, 1, 0,
 273             (SCM x, SCM lst, SCM pred),
 274             "Return a list containing the elements of @var{lst} but with\n"
 275             "those equal to @var{x} deleted.  The returned elements will be\n"
 276             "in the same order as they were in @var{lst}.\n"
 277             "\n"
 278             "Equality is determined by @var{pred}, or @code{equal?} if not\n"
 279             "given.  An equality call is made just once for each element,\n"
 280             "but the order in which the calls are made on the elements is\n"
 281             "unspecified.\n"
 282             "\n"
 283             "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
 284             "given @var{x} is first.  This means for instance elements\n"
 285             "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
 286             "\n"
 287             "@var{lst} is not modified, but the returned list might share a\n"
 288             "common tail with @var{lst}.")
 289 #define FUNC_NAME s_scm_srfi1_delete
 290 {
 291   SCM  ret, *p, keeplst;
 292   int  count;
 293
 294   if (SCM_UNBNDP (pred))
 295     return scm_delete (x, lst);
 296
 297   SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG3, FUNC_NAME);
 298
 299   /* ret is the return list being constructed.  p is where to append to it,
 300      initially &ret then SCM_CDRLOC of the last pair.  lst progresses as
 301      elements are considered.
 302
 303      Elements to be retained are not immediately copied, instead keeplst is
 304      the last pair in lst which is to be retained but not yet copied, count
 305      is how many from there are wanted.  When there's no more deletions, *p
 306      can be set to keeplst to share the remainder of the original lst.  (The
 307      entire original lst if there's no deletions at all.)  */
 308
 309   keeplst = lst;
 310   count = 0;
 311   p = &ret;
 312
 313   for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
 314     {
 315       if (scm_is_true (scm_call_2 (pred, x, SCM_CAR (lst))))
 316         {
 317           /* delete this element, so copy those at keeplst */
 318           p = list_copy_part (keeplst, count, p);
 319           keeplst = SCM_CDR (lst);
 320           count = 0;
 321         }
 322       else
 323         {
 324           /* keep this element */
 325           count++;
 326         }
 327     }
 328
 329   /* final retained elements */
 330   *p = keeplst;
 331
 332   /* demand that lst was a proper list */
 333   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
 334
 335   return ret;
 336 }
 337 #undef FUNC_NAME
 338
 339
 340 SCM_DEFINE (scm_srfi1_delete_x, "delete!", 2, 1, 0,
 341             (SCM x, SCM lst, SCM pred),
 342             "Return a list containing the elements of @var{lst} but with\n"
 343             "those equal to @var{x} deleted.  The returned elements will be\n"
 344             "in the same order as they were in @var{lst}.\n"
 345             "\n"
 346             "Equality is determined by @var{pred}, or @code{equal?} if not\n"
 347             "given.  An equality call is made just once for each element,\n"
 348             "but the order in which the calls are made on the elements is\n"
 349             "unspecified.\n"
 350             "\n"
 351             "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
 352             "given @var{x} is first.  This means for instance elements\n"
 353             "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
 354             "\n"
 355             "@var{lst} may be modified to construct the returned list.")
 356 #define FUNC_NAME s_scm_srfi1_delete_x
 357 {
 358   SCM walk;
 359   SCM *prev;
 360
 361   if (SCM_UNBNDP (pred))
 362     return scm_delete_x (x, lst);
 363
 364   SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG3, FUNC_NAME);
 365
 366   for (prev = &lst, walk = lst;
 367        scm_is_pair (walk);
 368        walk = SCM_CDR (walk))
 369     {
 370       if (scm_is_true (scm_call_2 (pred, x, SCM_CAR (walk))))
 371         *prev = SCM_CDR (walk);
 372       else
 373         prev = SCM_CDRLOC (walk);
 374     }
 375
 376   /* demand the input was a proper list */
 377   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (walk), walk, SCM_ARG2, FUNC_NAME,"list");
 378   return lst;
 379 }
 380 #undef FUNC_NAME
 381
 382
 383 SCM_DEFINE (scm_srfi1_delete_duplicates, "delete-duplicates", 1, 1, 0,
 384             (SCM lst, SCM pred),
 385             "Return a list containing the elements of @var{lst} but without\n"
 386             "duplicates.\n"
 387             "\n"
 388             "When elements are equal, only the first in @var{lst} is\n"
 389             "retained.  Equal elements can be anywhere in @var{lst}, they\n"
 390             "don't have to be adjacent.  The returned list will have the\n"
 391             "retained elements in the same order as they were in @var{lst}.\n"
 392             "\n"
 393             "Equality is determined by @var{pred}, or @code{equal?} if not\n"
 394             "given.  Calls @code{(pred x y)} are made with element @var{x}\n"
 395             "being before @var{y} in @var{lst}.  A call is made at most once\n"
 396             "for each combination, but the sequence of the calls across the\n"
 397             "elements is unspecified.\n"
 398             "\n"
 399             "@var{lst} is not modified, but the return might share a common\n"
 400             "tail with @var{lst}.\n"
 401             "\n"
 402             "In the worst case, this is an @math{O(N^2)} algorithm because\n"
 403             "it must check each element against all those preceding it.  For\n"
 404             "long lists it is more efficient to sort and then compare only\n"
 405             "adjacent elements.")
 406 #define FUNC_NAME s_scm_srfi1_delete_duplicates
 407 {
 408   scm_t_trampoline_2 equal_p;
 409   SCM  ret, *p, keeplst, item, l;
 410   int  count, i;
 411
 412   /* ret is the new list constructed.  p is where to append, initially &ret
 413      then SCM_CDRLOC of the last pair.  lst is advanced as each element is
 414      considered.
 415
 416      Elements retained are not immediately appended to ret, instead keeplst
 417      is the last pair in lst which is to be kept but is not yet copied.
 418      Initially this is the first pair of lst, since the first element is
 419      always retained.
 420
 421      *p is kept set to keeplst, so ret (inclusive) to lst (exclusive) is all
 422      the elements retained, making the equality search loop easy.
 423
 424      If an item must be deleted, elements from keeplst (inclusive) to lst
 425      (exclusive) must be copied and appended to ret.  When there's no more
 426      deletions, *p is left set to keeplst, so ret shares structure with the
 427      original lst.  (ret will be the entire original lst if there are no
 428      deletions.)  */
 429
 430   /* skip to end if an empty list (or something invalid) */
 431   ret = SCM_EOL;
 432
 433   if (SCM_UNBNDP (pred))
 434     equal_p = equal_trampoline;
 435   else
 436     {
 437       SCM_VALIDATE_PROC (SCM_ARG2, pred);
 438       equal_p = scm_call_2;
 439     }
 440
 441   keeplst = lst;
 442   count = 0;
 443   p = &ret;
 444
 445   for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
 446     {
 447       item = SCM_CAR (lst);
 448
 449       /* look for item in "ret" list */
 450       for (l = ret; scm_is_pair (l); l = SCM_CDR (l))
 451         {
 452           if (scm_is_true (equal_p (pred, SCM_CAR (l), item)))
 453             {
 454               /* "item" is a duplicate, so copy keeplst onto ret */
 455             duplicate:
 456               p = list_copy_part (keeplst, count, p);
 457
 458               keeplst = SCM_CDR (lst);  /* elem after the one deleted */
 459               count = 0;
 460               goto next_elem;
 461             }
 462         }
 463
 464       /* look for item in "keeplst" list
 465          be careful traversing, in case nasty code changed the cdrs */
 466       for (i = 0,       l = keeplst;
 467            i < count && scm_is_pair (l);
 468            i++,         l = SCM_CDR (l))
 469         if (scm_is_true (equal_p (pred, SCM_CAR (l), item)))
 470           goto duplicate;
 471
 472       /* keep this element */
 473       count++;
 474
 475     next_elem:
 476       ;
 477     }
 478   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG1, FUNC_NAME, "list");
 479
 480   /* share tail of keeplst items */
 481   *p = keeplst;
 482
 483   return ret;
 484 }
 485 #undef FUNC_NAME
 486
 487
 488 SCM_DEFINE (scm_srfi1_delete_duplicates_x, "delete-duplicates!", 1, 1, 0,
 489             (SCM lst, SCM pred),
 490             "Return a list containing the elements of @var{lst} but without\n"
 491             "duplicates.\n"
 492             "\n"
 493             "When elements are equal, only the first in @var{lst} is\n"
 494             "retained.  Equal elements can be anywhere in @var{lst}, they\n"
 495             "don't have to be adjacent.  The returned list will have the\n"
 496             "retained elements in the same order as they were in @var{lst}.\n"
 497             "\n"
 498             "Equality is determined by @var{pred}, or @code{equal?} if not\n"
 499             "given.  Calls @code{(pred x y)} are made with element @var{x}\n"
 500             "being before @var{y} in @var{lst}.  A call is made at most once\n"
 501             "for each combination, but the sequence of the calls across the\n"
 502             "elements is unspecified.\n"
 503             "\n"
 504             "@var{lst} may be modified to construct the returned list.\n"
 505             "\n"
 506             "In the worst case, this is an @math{O(N^2)} algorithm because\n"
 507             "it must check each element against all those preceding it.  For\n"
 508             "long lists it is more efficient to sort and then compare only\n"
 509             "adjacent elements.")
 510 #define FUNC_NAME s_scm_srfi1_delete_duplicates_x
 511 {
 512   scm_t_trampoline_2 equal_p;
 513   SCM  ret, endret, item, l;
 514
 515   /* ret is the return list, constructed from the pairs in lst.  endret is
 516      the last pair of ret, initially the first pair.  lst is advanced as
 517      elements are considered.  */
 518
 519   /* skip to end if an empty list (or something invalid) */
 520   ret = lst;
 521   if (scm_is_pair (lst))
 522     {
 523       if (SCM_UNBNDP (pred))
 524         equal_p = equal_trampoline;
 525       else
 526         {
 527           SCM_VALIDATE_PROC (SCM_ARG2, pred);
 528           equal_p = scm_call_2;
 529         }
 530
 531       endret = ret;
 532
 533       /* loop over lst elements starting from second */
 534       for (;;)
 535         {
 536           lst = SCM_CDR (lst);
 537           if (! scm_is_pair (lst))
 538             break;
 539           item = SCM_CAR (lst);
 540
 541           /* is item equal to any element from ret to endret (inclusive)? */
 542           l = ret;
 543           for (;;)
 544             {
 545               if (scm_is_true (equal_p (pred, SCM_CAR (l), item)))
 546                 break;  /* equal, forget this element */
 547
 548               if (scm_is_eq (l, endret))
 549                 {
 550                   /* not equal to any, so append this pair */
 551                   SCM_SETCDR (endret, lst);
 552                   endret = lst;
 553                   break;
 554                 }
 555               l = SCM_CDR (l);
 556             }
 557         }
 558
 559       /* terminate, in case last element was deleted */
 560       SCM_SETCDR (endret, SCM_EOL);
 561     }
 562
 563   /* demand that lst was a proper list */
 564   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG1, FUNC_NAME, "list");
 565
 566   return ret;
 567 }
 568 #undef FUNC_NAME
 569
 570
 571 SCM_DEFINE (scm_srfi1_find, "find", 2, 0, 0,
 572             (SCM pred, SCM lst),
 573             "Return the first element of @var{lst} which satisfies the\n"
 574             "predicate @var{pred}, or return @code{#f} if no such element is\n"
 575             "found.")
 576 #define FUNC_NAME s_scm_srfi1_find
 577 {
 578   SCM_VALIDATE_PROC (SCM_ARG1, pred);
 579
 580   for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
 581     {
 582       SCM elem = SCM_CAR (lst);
 583       if (scm_is_true (scm_call_1 (pred, elem)))
 584         return elem;
 585     }
 586   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
 587
 588   return SCM_BOOL_F;
 589 }
 590 #undef FUNC_NAME
 591
 592
 593 SCM_DEFINE (scm_srfi1_find_tail, "find-tail", 2, 0, 0,
 594             (SCM pred, SCM lst),
 595             "Return the first pair of @var{lst} whose @sc{car} satisfies the\n"
 596             "predicate @var{pred}, or return @code{#f} if no such element is\n"
 597             "found.")
 598 #define FUNC_NAME s_scm_srfi1_find_tail
 599 {
 600   SCM_VALIDATE_PROC (SCM_ARG1, pred);
 601
 602   for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
 603     if (scm_is_true (scm_call_1 (pred, SCM_CAR (lst))))
 604       return lst;
 605   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
 606
 607   return SCM_BOOL_F;
 608 }
 609 #undef FUNC_NAME
 610
 611 SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0,
 612             (SCM lst),
 613             "Return the length of @var{lst}, or @code{#f} if @var{lst} is\n"
 614             "circular.")
 615 #define FUNC_NAME s_scm_srfi1_length_plus
 616 {
 617   size_t i = 0;
 618   SCM tortoise = lst;
 619   SCM hare = lst;
 620
 621   do
 622     {
 623       if (SCM_NULL_OR_NIL_P (hare))
 624         return scm_from_size_t (i);
 625       if (!scm_is_pair (hare))
 626         scm_wrong_type_arg_msg (FUNC_NAME, 1, lst, "proper or circular list");
 627       hare = SCM_CDR (hare);
 628       i++;
 629       if (SCM_NULL_OR_NIL_P (hare))
 630         return scm_from_size_t (i);
 631       if (!scm_is_pair (hare))
 632         scm_wrong_type_arg_msg (FUNC_NAME, 1, lst, "proper or circular list");
 633       hare = SCM_CDR (hare);
 634       i++;
 635       /* For every two steps the hare takes, the tortoise takes one.  */
 636       tortoise = SCM_CDR(tortoise);
 637     }
 638   while (!scm_is_eq (hare, tortoise));
 639
 640   /* If the tortoise ever catches the hare, then the list must contain
 641      a cycle.  */
 642   return SCM_BOOL_F;
 643 }
 644 #undef FUNC_NAME
 645
 646
 647 /* This routine differs from the core list-copy in allowing improper lists.
 648    Maybe the core could allow them similarly.  */
 649
 650 SCM_DEFINE (scm_srfi1_list_copy, "list-copy", 1, 0, 0,
 651             (SCM lst),
 652             "Return a copy of the given list @var{lst}.\n"
 653             "\n"
 654             "@var{lst} can be a proper or improper list.  And if @var{lst}\n"
 655             "is not a pair then it's treated as the final tail of an\n"
 656             "improper list and simply returned.")
 657 #define FUNC_NAME s_scm_srfi1_list_copy
 658 {
 659   SCM newlst;
 660   SCM * fill_here;
 661   SCM from_here;
 662
 663   newlst = lst;
 664   fill_here = &newlst;
 665   from_here = lst;
 666
 667   while (scm_is_pair (from_here))
 668     {
 669       SCM c;
 670       c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here));
 671       *fill_here = c;
 672       fill_here = SCM_CDRLOC (c);
 673       from_here = SCM_CDR (from_here);
 674     }
 675   return newlst;
 676 }
 677 #undef FUNC_NAME
 678
 679 SCM_DEFINE (scm_srfi1_lset_difference_x, "lset-difference!", 2, 0, 1,
 680             (SCM equal, SCM lst, SCM rest),
 681             "Return @var{lst} with any elements in the lists in @var{rest}\n"
 682             "removed (ie.@: subtracted).  For only one @var{lst} argument,\n"
 683             "just that list is returned.\n"
 684             "\n"
 685             "The given @var{equal} procedure is used for comparing elements,\n"
 686             "called as @code{(@var{equal} elem1 elemN)}.  The first argument\n"
 687             "is from @var{lst} and the second from one of the subsequent\n"
 688             "lists.  But exactly which calls are made and in what order is\n"
 689             "unspecified.\n"
 690             "\n"
 691             "@example\n"
 692             "(lset-difference! eqv? (list 'x 'y))           @result{} (x y)\n"
 693             "(lset-difference! eqv? (list 1 2 3) '(3 1))    @result{} (2)\n"
 694             "(lset-difference! eqv? (list 1 2 3) '(3) '(2)) @result{} (1)\n"
 695             "@end example\n"
 696             "\n"
 697             "@code{lset-difference!} may modify @var{lst} to form its\n"
 698             "result.")
 699 #define FUNC_NAME s_scm_srfi1_lset_difference_x
 700 {
 701   SCM ret, *pos, elem, r, b;
 702   int argnum;
 703
 704   SCM_VALIDATE_PROC (SCM_ARG1, equal);
 705   SCM_VALIDATE_REST_ARGUMENT (rest);
 706
 707   ret = SCM_EOL;
 708   pos = &ret;
 709   for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
 710     {
 711       elem = SCM_CAR (lst);
 712
 713       for (r = rest, argnum = SCM_ARG3;
 714            scm_is_pair (r);
 715            r = SCM_CDR (r), argnum++)
 716         {
 717           for (b = SCM_CAR (r); scm_is_pair (b); b = SCM_CDR (b))
 718             if (scm_is_true (scm_call_2 (equal, elem, SCM_CAR (b))))
 719               goto next_elem; /* equal to elem, so drop that elem */
 720
 721           SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (b), b, argnum, FUNC_NAME,"list");
 722         }
 723
 724       /* elem not equal to anything in later lists, so keep it */
 725       *pos = lst;
 726       pos = SCM_CDRLOC (lst);
 727
 728     next_elem:
 729       ;
 730     }
 731   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
 732
 733   *pos = SCM_EOL;
 734   return ret;
 735 }
 736 #undef FUNC_NAME
 737
 738
 739 SCM_DEFINE (scm_srfi1_assoc, "assoc", 2, 1, 0,
 740             (SCM key, SCM alist, SCM pred),
 741             "Behaves like @code{assq} but uses third argument @var{pred}\n"
 742             "for key comparison.  If @var{pred} is not supplied,\n"
 743             "@code{equal?} is used.  (Extended from R5RS.)\n")
 744 #define FUNC_NAME s_scm_srfi1_assoc
 745 {
 746   SCM ls = alist;
 747   scm_t_trampoline_2 equal_p;
 748   if (SCM_UNBNDP (pred))
 749     equal_p = equal_trampoline;
 750   else
 751     {
 752       SCM_VALIDATE_PROC (SCM_ARG3, pred);
 753       equal_p = scm_call_2;
 754     }
 755   for(; scm_is_pair (ls); ls = SCM_CDR (ls))
 756     {
 757       SCM tmp = SCM_CAR (ls);
 758       SCM_ASSERT_TYPE (scm_is_pair (tmp), alist, SCM_ARG2, FUNC_NAME,
 759                        "association list");
 760       if (scm_is_true (equal_p (pred, key, SCM_CAR (tmp))))
 761         return tmp;
 762     }
 763   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls), alist, SCM_ARG2, FUNC_NAME,
 764                    "association list");
 765   return SCM_BOOL_F;
 766 }
 767 #undef FUNC_NAME
 768
 769 SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0,
 770             (SCM pred, SCM list),
 771             "Partition the elements of @var{list} with predicate @var{pred}.\n"
 772             "Return two values: the list of elements satisfying @var{pred} and\n"
 773             "the list of elements @emph{not} satisfying @var{pred}.  The order\n"
 774             "of the output lists follows the order of @var{list}.  @var{list}\n"
 775             "is not mutated.  One of the output lists may share memory with @var{list}.\n")
 776 #define FUNC_NAME s_scm_srfi1_partition
 777 {
 778   /* In this implementation, the output lists don't share memory with
 779      list, because it's probably not worth the effort. */
 780   SCM orig_list = list;
 781   SCM kept = scm_cons(SCM_EOL, SCM_EOL);
 782   SCM kept_tail = kept;
 783   SCM dropped = scm_cons(SCM_EOL, SCM_EOL);
 784   SCM dropped_tail = dropped;
 785
 786   SCM_VALIDATE_PROC (SCM_ARG1, pred);
 787
 788   for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR(list)) {
 789     SCM elt, new_tail;
 790
 791     /* Make sure LIST is not a dotted list.  */
 792     SCM_ASSERT (scm_is_pair (list), orig_list, SCM_ARG2, FUNC_NAME);
 793
 794     elt = SCM_CAR (list);
 795     new_tail = scm_cons (SCM_CAR (list), SCM_EOL);
 796
 797     if (scm_is_true (scm_call_1 (pred, elt))) {
 798       SCM_SETCDR(kept_tail, new_tail);
 799       kept_tail = new_tail;
 800     }
 801     else {
 802       SCM_SETCDR(dropped_tail, new_tail);
 803       dropped_tail = new_tail;
 804     }
 805   }
 806   /* re-use the initial conses for the values list */
 807   SCM_SETCAR(kept, SCM_CDR(kept));
 808   SCM_SETCDR(kept, dropped);
 809   SCM_SETCAR(dropped, SCM_CDR(dropped));
 810   SCM_SETCDR(dropped, SCM_EOL);
 811   return scm_values(kept);
 812 }
 813 #undef FUNC_NAME
 814
 815
 816 SCM_DEFINE (scm_srfi1_partition_x, "partition!", 2, 0, 0,
 817             (SCM pred, SCM lst),
 818             "Split @var{lst} into those elements which do and don't satisfy\n"
 819             "the predicate @var{pred}.\n"
 820             "\n"
 821             "The return is two values (@pxref{Multiple Values}), the first\n"
 822             "being a list of all elements from @var{lst} which satisfy\n"
 823             "@var{pred}, the second a list of those which do not.\n"
 824             "\n"
 825             "The elements in the result lists are in the same order as in\n"
 826             "@var{lst} but the order in which the calls @code{(@var{pred}\n"
 827             "elem)} are made on the list elements is unspecified.\n"
 828             "\n"
 829             "@var{lst} may be modified to construct the return lists.")
 830 #define FUNC_NAME s_scm_srfi1_partition_x
 831 {
 832   SCM  tlst, flst, *tp, *fp;
 833
 834   SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
 835
 836   /* tlst and flst are the lists of true and false elements.  tp and fp are
 837      where to store to append to them, initially &tlst and &flst, then
 838      SCM_CDRLOC of the last pair in the respective lists.  */
 839
 840   tlst = SCM_EOL;
 841   flst = SCM_EOL;
 842   tp = &tlst;
 843   fp = &flst;
 844
 845   for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
 846     {
 847       if (scm_is_true (scm_call_1 (pred, SCM_CAR (lst))))
 848         {
 849           *tp = lst;
 850           tp = SCM_CDRLOC (lst);
 851         }
 852       else
 853         {
 854           *fp = lst;
 855           fp = SCM_CDRLOC (lst);
 856         }
 857     }
 858
 859   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
 860
 861   /* terminate whichever didn't get the last element(s) */
 862   *tp = SCM_EOL;
 863   *fp = SCM_EOL;
 864
 865   return scm_values (scm_list_2 (tlst, flst));
 866 }
 867 #undef FUNC_NAME
 868
 869 SCM_DEFINE (scm_srfi1_remove, "remove", 2, 0, 0,
 870             (SCM pred, SCM list),
 871             "Return a list containing all elements from @var{list} which do\n"
 872             "not satisfy the predicate @var{pred}.  The elements in the\n"
 873             "result list have the same order as in @var{list}.  The order in\n"
 874             "which @var{pred} is applied to the list elements is not\n"
 875             "specified.")
 876 #define FUNC_NAME s_scm_srfi1_remove
 877 {
 878   SCM walk;
 879   SCM *prev;
 880   SCM res = SCM_EOL;
 881   SCM_VALIDATE_PROC (SCM_ARG1, pred);
 882   SCM_VALIDATE_LIST (2, list);
 883
 884   for (prev = &res, walk = list;
 885        scm_is_pair (walk);
 886        walk = SCM_CDR (walk))
 887     {
 888       if (scm_is_false (scm_call_1 (pred, SCM_CAR (walk))))
 889         {
 890           *prev = scm_cons (SCM_CAR (walk), SCM_EOL);
 891           prev = SCM_CDRLOC (*prev);
 892         }
 893     }
 894
 895   return res;
 896 }
 897 #undef FUNC_NAME
 898
 899
 900 SCM_DEFINE (scm_srfi1_remove_x, "remove!", 2, 0, 0,
 901             (SCM pred, SCM list),
 902             "Return a list containing all elements from @var{list} which do\n"
 903             "not satisfy the predicate @var{pred}.  The elements in the\n"
 904             "result list have the same order as in @var{list}.  The order in\n"
 905             "which @var{pred} is applied to the list elements is not\n"
 906             "specified.  @var{list} may be modified to build the return\n"
 907             "list.")
 908 #define FUNC_NAME s_scm_srfi1_remove_x
 909 {
 910   SCM walk;
 911   SCM *prev;
 912   SCM_VALIDATE_PROC (SCM_ARG1, pred);
 913   SCM_VALIDATE_LIST (2, list);
 914
 915   for (prev = &list, walk = list;
 916        scm_is_pair (walk);
 917        walk = SCM_CDR (walk))
 918     {
 919       if (scm_is_false (scm_call_1 (pred, SCM_CAR (walk))))
 920         prev = SCM_CDRLOC (walk);
 921       else
 922         *prev = SCM_CDR (walk);
 923     }
 924
 925   return list;
 926 }
 927 #undef FUNC_NAME
 928
 929 \f
 930 void
 931 scm_register_srfi_1 (void)
 932 {
 933   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
 934                             "scm_init_srfi_1",
 935                             (scm_t_extension_init_func)scm_init_srfi_1, NULL);
 936 }
 937
 938 void
 939 scm_init_srfi_1 (void)
 940 {
 941 #ifndef SCM_MAGIC_SNARFER
 942 #include "libguile/srfi-1.x"
 943 #endif
 944 }
 945
 946 /* End of srfi-1.c.  */