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, 2013
   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_0 (pred, args));
 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_is_pair (hare))
 624         {
 625           if (SCM_NULL_OR_NIL_P (hare))
 626             return scm_from_size_t (i);
 627           else
 628             scm_wrong_type_arg_msg (FUNC_NAME, 1, lst,
 629                                     "proper or circular list");
 630         }
 631       hare = SCM_CDR (hare);
 632       i++;
 633       if (!scm_is_pair (hare))
 634         {
 635           if (SCM_NULL_OR_NIL_P (hare))
 636             return scm_from_size_t (i);
 637           else
 638             scm_wrong_type_arg_msg (FUNC_NAME, 1, lst,
 639                                     "proper or circular list");
 640         }
 641       hare = SCM_CDR (hare);
 642       i++;
 643       /* For every two steps the hare takes, the tortoise takes one.  */
 644       tortoise = SCM_CDR (tortoise);
 645     }
 646   while (!scm_is_eq (hare, tortoise));
 647
 648   /* If the tortoise ever catches the hare, then the list must contain
 649      a cycle.  */
 650   return SCM_BOOL_F;
 651 }
 652 #undef FUNC_NAME
 653
 654
 655 /* This routine differs from the core list-copy in allowing improper lists.
 656    Maybe the core could allow them similarly.  */
 657
 658 SCM_DEFINE (scm_srfi1_list_copy, "list-copy", 1, 0, 0,
 659             (SCM lst),
 660             "Return a copy of the given list @var{lst}.\n"
 661             "\n"
 662             "@var{lst} can be a proper or improper list.  And if @var{lst}\n"
 663             "is not a pair then it's treated as the final tail of an\n"
 664             "improper list and simply returned.")
 665 #define FUNC_NAME s_scm_srfi1_list_copy
 666 {
 667   SCM newlst;
 668   SCM * fill_here;
 669   SCM from_here;
 670
 671   newlst = lst;
 672   fill_here = &newlst;
 673   from_here = lst;
 674
 675   while (scm_is_pair (from_here))
 676     {
 677       SCM c;
 678       c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here));
 679       *fill_here = c;
 680       fill_here = SCM_CDRLOC (c);
 681       from_here = SCM_CDR (from_here);
 682     }
 683   return newlst;
 684 }
 685 #undef FUNC_NAME
 686
 687 SCM_DEFINE (scm_srfi1_lset_difference_x, "lset-difference!", 2, 0, 1,
 688             (SCM equal, SCM lst, SCM rest),
 689             "Return @var{lst} with any elements in the lists in @var{rest}\n"
 690             "removed (ie.@: subtracted).  For only one @var{lst} argument,\n"
 691             "just that list is returned.\n"
 692             "\n"
 693             "The given @var{equal} procedure is used for comparing elements,\n"
 694             "called as @code{(@var{equal} elem1 elemN)}.  The first argument\n"
 695             "is from @var{lst} and the second from one of the subsequent\n"
 696             "lists.  But exactly which calls are made and in what order is\n"
 697             "unspecified.\n"
 698             "\n"
 699             "@example\n"
 700             "(lset-difference! eqv? (list 'x 'y))           @result{} (x y)\n"
 701             "(lset-difference! eqv? (list 1 2 3) '(3 1))    @result{} (2)\n"
 702             "(lset-difference! eqv? (list 1 2 3) '(3) '(2)) @result{} (1)\n"
 703             "@end example\n"
 704             "\n"
 705             "@code{lset-difference!} may modify @var{lst} to form its\n"
 706             "result.")
 707 #define FUNC_NAME s_scm_srfi1_lset_difference_x
 708 {
 709   SCM ret, *pos, elem, r, b;
 710   int argnum;
 711
 712   SCM_VALIDATE_PROC (SCM_ARG1, equal);
 713   SCM_VALIDATE_REST_ARGUMENT (rest);
 714
 715   ret = SCM_EOL;
 716   pos = &ret;
 717   for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
 718     {
 719       elem = SCM_CAR (lst);
 720
 721       for (r = rest, argnum = SCM_ARG3;
 722            scm_is_pair (r);
 723            r = SCM_CDR (r), argnum++)
 724         {
 725           for (b = SCM_CAR (r); scm_is_pair (b); b = SCM_CDR (b))
 726             if (scm_is_true (scm_call_2 (equal, elem, SCM_CAR (b))))
 727               goto next_elem; /* equal to elem, so drop that elem */
 728
 729           SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (b), b, argnum, FUNC_NAME,"list");
 730         }
 731
 732       /* elem not equal to anything in later lists, so keep it */
 733       *pos = lst;
 734       pos = SCM_CDRLOC (lst);
 735
 736     next_elem:
 737       ;
 738     }
 739   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
 740
 741   *pos = SCM_EOL;
 742   return ret;
 743 }
 744 #undef FUNC_NAME
 745
 746
 747 SCM_DEFINE (scm_srfi1_assoc, "assoc", 2, 1, 0,
 748             (SCM key, SCM alist, SCM pred),
 749             "Behaves like @code{assq} but uses third argument @var{pred}\n"
 750             "for key comparison.  If @var{pred} is not supplied,\n"
 751             "@code{equal?} is used.  (Extended from R5RS.)\n")
 752 #define FUNC_NAME s_scm_srfi1_assoc
 753 {
 754   SCM ls = alist;
 755   scm_t_trampoline_2 equal_p;
 756   if (SCM_UNBNDP (pred))
 757     equal_p = equal_trampoline;
 758   else
 759     {
 760       SCM_VALIDATE_PROC (SCM_ARG3, pred);
 761       equal_p = scm_call_2;
 762     }
 763   for(; scm_is_pair (ls); ls = SCM_CDR (ls))
 764     {
 765       SCM tmp = SCM_CAR (ls);
 766       SCM_ASSERT_TYPE (scm_is_pair (tmp), alist, SCM_ARG2, FUNC_NAME,
 767                        "association list");
 768       if (scm_is_true (equal_p (pred, key, SCM_CAR (tmp))))
 769         return tmp;
 770     }
 771   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls), alist, SCM_ARG2, FUNC_NAME,
 772                    "association list");
 773   return SCM_BOOL_F;
 774 }
 775 #undef FUNC_NAME
 776
 777 SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0,
 778             (SCM pred, SCM list),
 779             "Partition the elements of @var{list} with predicate @var{pred}.\n"
 780             "Return two values: the list of elements satisfying @var{pred} and\n"
 781             "the list of elements @emph{not} satisfying @var{pred}.  The order\n"
 782             "of the output lists follows the order of @var{list}.  @var{list}\n"
 783             "is not mutated.  One of the output lists may share memory with @var{list}.\n")
 784 #define FUNC_NAME s_scm_srfi1_partition
 785 {
 786   /* In this implementation, the output lists don't share memory with
 787      list, because it's probably not worth the effort. */
 788   SCM orig_list = list;
 789   SCM kept = scm_cons(SCM_EOL, SCM_EOL);
 790   SCM kept_tail = kept;
 791   SCM dropped = scm_cons(SCM_EOL, SCM_EOL);
 792   SCM dropped_tail = dropped;
 793
 794   SCM_VALIDATE_PROC (SCM_ARG1, pred);
 795
 796   for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR(list)) {
 797     SCM elt, new_tail;
 798
 799     /* Make sure LIST is not a dotted list.  */
 800     SCM_ASSERT (scm_is_pair (list), orig_list, SCM_ARG2, FUNC_NAME);
 801
 802     elt = SCM_CAR (list);
 803     new_tail = scm_cons (SCM_CAR (list), SCM_EOL);
 804
 805     if (scm_is_true (scm_call_1 (pred, elt))) {
 806       SCM_SETCDR(kept_tail, new_tail);
 807       kept_tail = new_tail;
 808     }
 809     else {
 810       SCM_SETCDR(dropped_tail, new_tail);
 811       dropped_tail = new_tail;
 812     }
 813   }
 814   /* re-use the initial conses for the values list */
 815   SCM_SETCAR(kept, SCM_CDR(kept));
 816   SCM_SETCDR(kept, dropped);
 817   SCM_SETCAR(dropped, SCM_CDR(dropped));
 818   SCM_SETCDR(dropped, SCM_EOL);
 819   return scm_values(kept);
 820 }
 821 #undef FUNC_NAME
 822
 823
 824 SCM_DEFINE (scm_srfi1_partition_x, "partition!", 2, 0, 0,
 825             (SCM pred, SCM lst),
 826             "Split @var{lst} into those elements which do and don't satisfy\n"
 827             "the predicate @var{pred}.\n"
 828             "\n"
 829             "The return is two values (@pxref{Multiple Values}), the first\n"
 830             "being a list of all elements from @var{lst} which satisfy\n"
 831             "@var{pred}, the second a list of those which do not.\n"
 832             "\n"
 833             "The elements in the result lists are in the same order as in\n"
 834             "@var{lst} but the order in which the calls @code{(@var{pred}\n"
 835             "elem)} are made on the list elements is unspecified.\n"
 836             "\n"
 837             "@var{lst} may be modified to construct the return lists.")
 838 #define FUNC_NAME s_scm_srfi1_partition_x
 839 {
 840   SCM  tlst, flst, *tp, *fp;
 841
 842   SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
 843
 844   /* tlst and flst are the lists of true and false elements.  tp and fp are
 845      where to store to append to them, initially &tlst and &flst, then
 846      SCM_CDRLOC of the last pair in the respective lists.  */
 847
 848   tlst = SCM_EOL;
 849   flst = SCM_EOL;
 850   tp = &tlst;
 851   fp = &flst;
 852
 853   for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
 854     {
 855       if (scm_is_true (scm_call_1 (pred, SCM_CAR (lst))))
 856         {
 857           *tp = lst;
 858           tp = SCM_CDRLOC (lst);
 859         }
 860       else
 861         {
 862           *fp = lst;
 863           fp = SCM_CDRLOC (lst);
 864         }
 865     }
 866
 867   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
 868
 869   /* terminate whichever didn't get the last element(s) */
 870   *tp = SCM_EOL;
 871   *fp = SCM_EOL;
 872
 873   return scm_values (scm_list_2 (tlst, flst));
 874 }
 875 #undef FUNC_NAME
 876
 877 SCM_DEFINE (scm_srfi1_remove, "remove", 2, 0, 0,
 878             (SCM pred, SCM list),
 879             "Return a list containing all elements from @var{list} which do\n"
 880             "not satisfy the predicate @var{pred}.  The elements in the\n"
 881             "result list have the same order as in @var{list}.  The order in\n"
 882             "which @var{pred} is applied to the list elements is not\n"
 883             "specified.")
 884 #define FUNC_NAME s_scm_srfi1_remove
 885 {
 886   SCM walk;
 887   SCM *prev;
 888   SCM res = SCM_EOL;
 889   SCM_VALIDATE_PROC (SCM_ARG1, pred);
 890   SCM_VALIDATE_LIST (2, list);
 891
 892   for (prev = &res, walk = list;
 893        scm_is_pair (walk);
 894        walk = SCM_CDR (walk))
 895     {
 896       if (scm_is_false (scm_call_1 (pred, SCM_CAR (walk))))
 897         {
 898           *prev = scm_cons (SCM_CAR (walk), SCM_EOL);
 899           prev = SCM_CDRLOC (*prev);
 900         }
 901     }
 902
 903   return res;
 904 }
 905 #undef FUNC_NAME
 906
 907
 908 SCM_DEFINE (scm_srfi1_remove_x, "remove!", 2, 0, 0,
 909             (SCM pred, SCM list),
 910             "Return a list containing all elements from @var{list} which do\n"
 911             "not satisfy the predicate @var{pred}.  The elements in the\n"
 912             "result list have the same order as in @var{list}.  The order in\n"
 913             "which @var{pred} is applied to the list elements is not\n"
 914             "specified.  @var{list} may be modified to build the return\n"
 915             "list.")
 916 #define FUNC_NAME s_scm_srfi1_remove_x
 917 {
 918   SCM walk;
 919   SCM *prev;
 920   SCM_VALIDATE_PROC (SCM_ARG1, pred);
 921   SCM_VALIDATE_LIST (2, list);
 922
 923   for (prev = &list, walk = list;
 924        scm_is_pair (walk);
 925        walk = SCM_CDR (walk))
 926     {
 927       if (scm_is_false (scm_call_1 (pred, SCM_CAR (walk))))
 928         prev = SCM_CDRLOC (walk);
 929       else
 930         *prev = SCM_CDR (walk);
 931     }
 932
 933   return list;
 934 }
 935 #undef FUNC_NAME
 936
 937 \f
 938 void
 939 scm_register_srfi_1 (void)
 940 {
 941   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
 942                             "scm_init_srfi_1",
 943                             (scm_t_extension_init_func)scm_init_srfi_1, NULL);
 944 }
 945
 946 void
 947 scm_init_srfi_1 (void)
 948 {
 949 #ifndef SCM_MAGIC_SNARFER
 950 #include "libguile/srfi-1.x"
 951 #endif
 952 }
 953
 954 /* End of srfi-1.c.  */