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