libguile/srfi-1.c

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